Keskustelu: Koodit: VB6: Pelin FPS:n hallinta: tapahtumien moniajo

Option Explicit

Private Const FRAMES_PER_SECOND = 60
Private Const MOVES_PER_SECOND = 240

Public Enum TICK_INDEX
    TICK_INTERNAL = 0   ' for internal processing (moving objects, checking keyboard state etc.)
    TICK_DISPLAY = 1    ' for updating the screen
    TICK_SECOND = 2     ' for displaying FPS information once a second
End Enum

Private Type TICKS
    Count As Long       ' number of ticks done
    Ending As Currency  ' the next ending tick
    Freq As Currency    ' tick frequency
End Type

Private dblFreqToMS As Double   ' to convert frequency to millisecond
Private curLateTick As Currency ' start skipping when more late than this value
Private udtTicks(2) As TICKS     ' the array to hold tick information

' the API declarations
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' this function will wait for the next tick and returns the index that is about to happen
Public Function GetNextTickIndex() As TICK_INDEX
    Dim lngA As Long, curDifference As Currency, enmIndex As TICK_INDEX
    Dim curTick As Currency
    ' we skip the first item, because we default for it
    For lngA = 1 To UBound(udtTicks)
        ' check if this tick will be processed next
        If udtTicks(lngA).Ending < udtTicks(enmIndex).Ending Then enmIndex = lngA
    Next lngA
    ' increase tick index
    udtTicks(enmIndex).Count = udtTicks(enmIndex).Count + 1
    ' get current tick
    QueryPerformanceCounter curTick
    ' because of the falling behind prevention, we need to set this to correct value
    If udtTicks(enmIndex).Ending = 0 Then udtTicks(enmIndex).Ending = curTick
    ' then wait for the tick
    curDifference = udtTicks(enmIndex).Ending - curTick
    If curDifference >= 0 Then
        lngA = CLng(CDbl(curDifference) * dblFreqToMS)
        ' do we need to sleep? (this prevents 100% processor usage!)
        If lngA > 0 Then
            Sleep lngA
            ' prevent being late
            QueryPerformanceCounter curTick
            curDifference = udtTicks(enmIndex).Ending - curTick
            ' set the next tick
            SetNextTick enmIndex, -curDifference
        Else
            ' set the next tick
            SetNextTick enmIndex
        End If
    Else
        If curDifference > curLateTick Then
            ' WE ARE LATE, but not too badly
            SetNextTick enmIndex, -curDifference
        Else
            ' WE ARE BADLY LATE, so we have to skip processing :/
            ' otherwise on slow computers the things just get worse and worse...
            SetNextTick enmIndex
        End If
    End If
    ' return the tick index
    GetNextTickIndex = enmIndex
End Function
Public Function GetTickCount(ByVal Index As TICK_INDEX) As Long
    ' return the current tick count
    GetTickCount = udtTicks(Index).Count
End Function
Public Sub Init_Ticks()
    Dim curFreq As Currency, curTick As Currency
    ' we need a good timer: use queryperformancecounter
    QueryPerformanceFrequency curFreq
    ' calculate frequency to second value
    dblFreqToMS = 1000 / CDbl(curFreq)
    ' when we skip stuff?
    curLateTick = -(curFreq / 20)
    ' set frequencies
    udtTicks(TICK_INTERNAL).Freq = curFreq / MOVES_PER_SECOND
    udtTicks(TICK_DISPLAY).Freq = curFreq / FRAMES_PER_SECOND
    udtTicks(TICK_SECOND).Freq = curFreq
End Sub
Public Sub ResetTickCount(ByVal Index As TICK_INDEX)
    udtTicks(Index).Count = 0
End Sub
Private Sub SetNextTick(ByVal Index As TICK_INDEX, Optional ByVal curFallBehind As Currency = 0)
    Dim curTick As Currency
    ' get current tick
    QueryPerformanceCounter curTick
    ' set next event to future
    udtTicks(Index).Ending = curTick + udtTicks(Index).Freq - curFallBehind
End Sub

Option Explicit

' nämä kutsut ovat parempaa DoEventsin hallintaa varten
' mitä sitä turhaan hidasta DoEventsiä kutsumaan, jos sille ei ole tarvetta...
Public Const QS_KEY = &H1&
Public Const QS_MOUSEMOVE = &H2&
Public Const QS_MOUSEBUTTON = &H4&
Public Const QS_POSTMESSAGE = &H8&
Public Const QS_TIMER = &H10&
Public Const QS_PAINT = &H20&
Public Const QS_SENDMESSAGE = &H40&
Public Const QS_HOTKEY = &H80&
Public Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
Public Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Public Const QS_INPUT = (QS_MOUSE Or QS_KEY)
Public Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)

Public Declare Function GetQueueStatus Lib "user32" (ByVal qsFlags As Long) As Long

' kun tämän muuttaa arvoon True, ohjelma sulkeutuu
Public Quit As Boolean

Private Sub Main()
    ' alusta päivityksenhallinta
    Init_Ticks
    ' näytä pääformi
    Form1.Show
    ' jatketaan kunnes Quit on asetettu arvoon True
    Do While Not Quit
        ' odota kunnes seuraava tapahtuma tapahtuu
        ' GetNextTickIndex löytyy modTicks.bas-tiedostosta
        ' ohjelma on pysähtynyt GetNextTickIndexiin kunnes jotain pitäisi tapahtua
        ' funktio palauttaa arvon, joka kertoo mikä koodi pitäisi nyt suorittaa
        Select Case GetNextTickIndex

        ' sisäisen koodin hallinta
            Case TICK_INTERNAL
                ' tänne voi kirjoittaa esim.:
                ' - ammusten ja pelaajien liikuttelun
                ' - törmäysten tunnistamisen
                ' - näppäimistön ja hiiren lukemisen
        ' ruudunpäivityksen hallinta
            Case TICK_DISPLAY
                ' tänne voi kirjoittaa ruudunpäivityksen, esim.:
                ' - hae kopio taustabufferista (jossa ei ole objekteja yms.)
                ' - piirrä ruudulla näkyvät ammukset, pelaajat ja viholliset kopiobufferiin
                ' - piirrä bufferi ruudulle näkyviin
        ' sekunttipäivitys
            Case TICK_SECOND
                ' näytä formin otsikossa sekuntin välein kuinka paljon on tapahtumia tapahtunut
                Form1.Caption = _
                    "FPS: " & Str$(GetTickCount(TICK_DISPLAY)) & _
                    " | MPS: " & Str$(GetTickCount(TICK_INTERNAL)) & _
                    " | " & Format$(TimeSerial(0, 0, CInt(GetTickCount(TICK_SECOND) And &HFFFF)), "n:ss")
                ' nollaa laskurit
                ResetTickCount TICK_DISPLAY
                ResetTickCount TICK_INTERNAL
        End Select

        ' estä ohjelmaa jäämästä jumiin antamalla Windowsille aikaa suorittaa moniajoa
        ' tämä pitää huolen siitä, että DoEventsiä kutsutaan vain silloin kun sille on tarvetta
        ' tämä on tärkeää, koska DoEvents on hidas ja tätä koodirykelmää suoritetaan todella monesti sekuntia kohden
        If GetQueueStatus(QS_SENDMESSAGE Or QS_ALLEVENTS) <> 0 Then DoEvents
    Loop
    ' poista Form1 muistista
    Set Form1 = Nothing
End Sub