twirl-0.4.0.3: src/Twirl.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Twirl (
  runApp
  , TwirlConfig (..)
  , TwirlMonad
  , module Twirl.Inputs
  , module Keys
) where

import Control.Concurrent (threadDelay)
import Control.Exception (bracket_)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.List (sortBy)
import Data.Ord (comparing)
import Foreign.C.Types (CInt)
import SDL hiding (get)
import qualified SDL.Font as Font
import qualified SDL.Input.Keyboard.Codes as Keys
import qualified SDL.Mixer as Mixer
import Twirl.Graphics
import Twirl.Inputs

data TwirlConfig a = TwirlConfig
  { initialState :: TwirlMonad a
  , updateFunction :: a -> InputState -> Double -> TwirlMonad a
  , drawFunction :: a -> TwirlMonad ()
  , fps :: Int
  }

runApp :: TwirlConfig a -> IO ()
runApp config@TwirlConfig{..} = do
  initializeAll
  withFont $ do
    Mixer.withAudio Mixer.defaultAudio audioChunkSize $ do
      displays <- getDisplays
      let primaryWindowSize = getPrimaryDisplaySize displays
          windowSettings = defaultWindow{windowInitialSize = primaryWindowSize, windowBorder = False}
      window <- createWindow "" windowSettings
      defaultFont <- loadDefaultFont
      rendererType <- chooseRendererType
      let rendererSettings =
            RendererConfig
              { rendererType = rendererType
              , rendererTargetTexture = True
              }
      renderer <- createRenderer window (-1) rendererSettings
      rendererDrawBlendMode renderer $= BlendAlphaBlend
      _ <- flip runTwirlMonad (TwirlContext renderer window defaultFont) $ do
        state <- initialState
        fpsState <-
          liftIO $
            initFPSState
              60
              ( case rendererType of
                  AcceleratedVSyncRenderer -> True
                  _ -> False
              )
        appLoop config state emptyInputState renderer 0 fpsState window
      pure ()

withFont :: IO () -> IO ()
withFont = bracket_ Font.initialize Font.quit

getPrimaryDisplaySize :: [Display] -> V2 CInt
getPrimaryDisplaySize modes =
  let primaryModes = filter ((==) (P (V2 0 0)) . displayBoundsPosition) modes
   in displayBoundsSize $ head primaryModes

chooseRendererType :: IO RendererType
chooseRendererType = do
  rendererInfos <- getRenderDriverInfo
  pure $ case sortBy (comparing rendererPriority) rendererInfos of
    p : _ -> getRendererType p
    [] -> SoftwareRenderer
 where
  getRendererType RendererInfo{rendererInfoFlags = RendererConfig{rendererType}} = rendererType
  rendererPriority rendererInfo =
    case getRendererType rendererInfo of
      AcceleratedRenderer -> 1 :: Int
      AcceleratedVSyncRenderer -> 2
      UnacceleratedRenderer -> 3
      SoftwareRenderer -> 4

audioChunkSize :: Int
audioChunkSize = 128

appLoop :: TwirlConfig a -> a -> InputState -> Renderer -> Double -> FPSState -> Window -> TwirlMonad ()
appLoop config@TwirlConfig{..} state previousInputState renderer carriedOverAccumulator fpsState window = do
  (newInputState, quitApp) <- updateInputs previousInputState
  (newFPSState, frameTime) <- sleepRemainingTime fpsState
  (newState, remainingAccumulator) <- updateState state newInputState (carriedOverAccumulator + frameTime)

  rendererDrawColor renderer $= V4 255 255 255 255
  clear renderer
  drawFunction newState
  present renderer
  if quitApp
    then closeControllers newInputState
    else appLoop config newState newInputState renderer remainingAccumulator newFPSState window
 where
  updateState previousState inputState accumulator = do
    let timeStep = 1 / (fromIntegral fps)
    if accumulator > timeStep
      then do
        newState <- updateFunction previousState inputState timeStep
        updateState newState inputState (accumulator - timeStep)
      else do
        pure (previousState, accumulator)

data FPSState = FPSState
  { frameCount :: !Int
  , resetTime :: !Double
  , secondsPerFrame :: !Double
  , lastTime :: !Double
  , vsyncActive :: !Bool
  }

sleepRemainingTime :: MonadIO m => FPSState -> m (FPSState, Double)
sleepRemainingTime fpsState@FPSState{frameCount, resetTime, secondsPerFrame, lastTime, vsyncActive} = do
  currentTime <- time
  let targetTime = resetTime + (fromIntegral frameCount) * secondsPerFrame
      frameTime = currentTime - lastTime
  if vsyncActive
    then pure (fpsState{frameCount = frameCount + 1, lastTime = currentTime}, frameTime)
    else
      if currentTime <= targetTime
        then do
          let requestedDelay = round $ (targetTime - currentTime) * 1000000
          liftIO $ threadDelay requestedDelay
          pure (fpsState{frameCount = frameCount + 1, lastTime = currentTime}, frameTime)
        else do
          pure (fpsState{frameCount = 1, resetTime = currentTime, secondsPerFrame = secondsPerFrame, lastTime = currentTime}, frameTime)

initFPSState :: Int -> Bool -> IO FPSState
initFPSState fps vsyncActive = do
  startTime <- time
  pure $ FPSState 0 startTime (1 / (fromIntegral fps)) startTime vsyncActive