{-# 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
  { forall a. TwirlConfig a -> TwirlMonad a
initialState :: TwirlMonad a
  , forall a.
TwirlConfig a -> a -> InputState -> Double -> TwirlMonad a
updateFunction :: a -> InputState -> Double -> TwirlMonad a
  , forall a. TwirlConfig a -> a -> TwirlMonad ()
drawFunction :: a -> TwirlMonad ()
  , forall a. TwirlConfig a -> Int
fps :: Int
  }

runApp :: TwirlConfig a -> IO ()
runApp :: forall a. TwirlConfig a -> IO ()
runApp config :: TwirlConfig a
config@TwirlConfig{Int
TwirlMonad a
a -> TwirlMonad ()
a -> InputState -> Double -> TwirlMonad a
fps :: Int
drawFunction :: a -> TwirlMonad ()
updateFunction :: a -> InputState -> Double -> TwirlMonad a
initialState :: TwirlMonad a
fps :: forall a. TwirlConfig a -> Int
drawFunction :: forall a. TwirlConfig a -> a -> TwirlMonad ()
updateFunction :: forall a.
TwirlConfig a -> a -> InputState -> Double -> TwirlMonad a
initialState :: forall a. TwirlConfig a -> TwirlMonad a
..} = do
  IO ()
forall (m :: * -> *). (Functor m, MonadIO m) => m ()
initializeAll
  IO () -> IO ()
withFont (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Audio -> Int -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadIO m) =>
Audio -> Int -> m a -> m a
Mixer.withAudio Audio
Mixer.defaultAudio Int
audioChunkSize (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Display]
displays <- IO [Display]
forall (m :: * -> *). MonadIO m => m [Display]
getDisplays
      let primaryWindowSize :: V2 CInt
primaryWindowSize = [Display] -> V2 CInt
getPrimaryDisplaySize [Display]
displays
          windowSettings :: WindowConfig
windowSettings = WindowConfig
defaultWindow{windowInitialSize :: V2 CInt
windowInitialSize = V2 CInt
primaryWindowSize, windowBorder :: Bool
windowBorder = Bool
False}
      Window
window <- Text -> WindowConfig -> IO Window
forall (m :: * -> *). MonadIO m => Text -> WindowConfig -> m Window
createWindow Text
"" WindowConfig
windowSettings
      Font
defaultFont <- IO Font
forall (m :: * -> *). MonadIO m => m Font
loadDefaultFont
      RendererType
rendererType <- IO RendererType
chooseRendererType
      let rendererSettings :: RendererConfig
rendererSettings =
            RendererConfig
              { rendererType :: RendererType
rendererType = RendererType
rendererType
              , rendererTargetTexture :: Bool
rendererTargetTexture = Bool
True
              }
      Renderer
renderer <- Window -> CInt -> RendererConfig -> IO Renderer
forall (m :: * -> *).
MonadIO m =>
Window -> CInt -> RendererConfig -> m Renderer
createRenderer Window
window (-CInt
1) RendererConfig
rendererSettings
      Renderer -> StateVar BlendMode
rendererDrawBlendMode Renderer
renderer StateVar BlendMode -> BlendMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= BlendMode
BlendAlphaBlend
      ((), TwirlContext)
_ <- (TwirlMonad () -> TwirlContext -> IO ((), TwirlContext))
-> TwirlContext -> TwirlMonad () -> IO ((), TwirlContext)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TwirlMonad () -> TwirlContext -> IO ((), TwirlContext)
forall a. TwirlMonad a -> TwirlContext -> IO (a, TwirlContext)
runTwirlMonad (Renderer -> Window -> Font -> TwirlContext
TwirlContext Renderer
renderer Window
window Font
defaultFont) (TwirlMonad () -> IO ((), TwirlContext))
-> TwirlMonad () -> IO ((), TwirlContext)
forall a b. (a -> b) -> a -> b
$ do
        a
state <- TwirlMonad a
initialState
        FPSState
fpsState <-
          IO FPSState -> TwirlMonad FPSState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FPSState -> TwirlMonad FPSState)
-> IO FPSState -> TwirlMonad FPSState
forall a b. (a -> b) -> a -> b
$
            Int -> Bool -> IO FPSState
initFPSState
              Int
60
              ( case RendererType
rendererType of
                  RendererType
AcceleratedVSyncRenderer -> Bool
True
                  RendererType
_ -> Bool
False
              )
        TwirlConfig a
-> a
-> InputState
-> Renderer
-> Double
-> FPSState
-> Window
-> TwirlMonad ()
forall a.
TwirlConfig a
-> a
-> InputState
-> Renderer
-> Double
-> FPSState
-> Window
-> TwirlMonad ()
appLoop TwirlConfig a
config a
state InputState
emptyInputState Renderer
renderer Double
0 FPSState
fpsState Window
window
      () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

withFont :: IO () -> IO ()
withFont :: IO () -> IO ()
withFont = IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
forall (m :: * -> *). MonadIO m => m ()
Font.initialize IO ()
forall (m :: * -> *). MonadIO m => m ()
Font.quit

getPrimaryDisplaySize :: [Display] -> V2 CInt
getPrimaryDisplaySize :: [Display] -> V2 CInt
getPrimaryDisplaySize [Display]
modes =
  let primaryModes :: [Display]
primaryModes = (Display -> Bool) -> [Display] -> [Display]
forall a. (a -> Bool) -> [a] -> [a]
filter (Point V2 CInt -> Point V2 CInt -> Bool
forall a. Eq a => a -> a -> Bool
(==) (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 CInt
0 CInt
0)) (Point V2 CInt -> Bool)
-> (Display -> Point V2 CInt) -> Display -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> Point V2 CInt
displayBoundsPosition) [Display]
modes
   in Display -> V2 CInt
displayBoundsSize (Display -> V2 CInt) -> Display -> V2 CInt
forall a b. (a -> b) -> a -> b
$ [Display] -> Display
forall a. [a] -> a
head [Display]
primaryModes

chooseRendererType :: IO RendererType
chooseRendererType :: IO RendererType
chooseRendererType = do
  [RendererInfo]
rendererInfos <- IO [RendererInfo]
forall (m :: * -> *). MonadIO m => m [RendererInfo]
getRenderDriverInfo
  RendererType -> IO RendererType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RendererType -> IO RendererType)
-> RendererType -> IO RendererType
forall a b. (a -> b) -> a -> b
$ case (RendererInfo -> RendererInfo -> Ordering)
-> [RendererInfo] -> [RendererInfo]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((RendererInfo -> Int) -> RendererInfo -> RendererInfo -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing RendererInfo -> Int
rendererPriority) [RendererInfo]
rendererInfos of
    RendererInfo
p : [RendererInfo]
_ -> RendererInfo -> RendererType
getRendererType RendererInfo
p
    [] -> RendererType
SoftwareRenderer
 where
  getRendererType :: RendererInfo -> RendererType
getRendererType RendererInfo{rendererInfoFlags :: RendererInfo -> RendererConfig
rendererInfoFlags = RendererConfig{RendererType
rendererType :: RendererType
rendererType :: RendererConfig -> RendererType
rendererType}} = RendererType
rendererType
  rendererPriority :: RendererInfo -> Int
rendererPriority RendererInfo
rendererInfo =
    case RendererInfo -> RendererType
getRendererType RendererInfo
rendererInfo of
      RendererType
AcceleratedRenderer -> Int
1 :: Int
      RendererType
AcceleratedVSyncRenderer -> Int
2
      RendererType
UnacceleratedRenderer -> Int
3
      RendererType
SoftwareRenderer -> Int
4

audioChunkSize :: Int
audioChunkSize :: Int
audioChunkSize = Int
128

appLoop :: TwirlConfig a -> a -> InputState -> Renderer -> Double -> FPSState -> Window -> TwirlMonad ()
appLoop :: forall a.
TwirlConfig a
-> a
-> InputState
-> Renderer
-> Double
-> FPSState
-> Window
-> TwirlMonad ()
appLoop config :: TwirlConfig a
config@TwirlConfig{Int
TwirlMonad a
a -> TwirlMonad ()
a -> InputState -> Double -> TwirlMonad a
fps :: Int
drawFunction :: a -> TwirlMonad ()
updateFunction :: a -> InputState -> Double -> TwirlMonad a
initialState :: TwirlMonad a
fps :: forall a. TwirlConfig a -> Int
drawFunction :: forall a. TwirlConfig a -> a -> TwirlMonad ()
updateFunction :: forall a.
TwirlConfig a -> a -> InputState -> Double -> TwirlMonad a
initialState :: forall a. TwirlConfig a -> TwirlMonad a
..} a
state InputState
previousInputState Renderer
renderer Double
carriedOverAccumulator FPSState
fpsState Window
window = do
  (InputState
newInputState, Bool
quitApp) <- InputState -> TwirlMonad (InputState, Bool)
forall (m :: * -> *).
MonadIO m =>
InputState -> m (InputState, Bool)
updateInputs InputState
previousInputState
  (FPSState
newFPSState, Double
frameTime) <- FPSState -> TwirlMonad (FPSState, Double)
forall (m :: * -> *). MonadIO m => FPSState -> m (FPSState, Double)
sleepRemainingTime FPSState
fpsState
  (a
newState, Double
remainingAccumulator) <- a -> InputState -> Double -> TwirlMonad (a, Double)
updateState a
state InputState
newInputState (Double
carriedOverAccumulator Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
frameTime)

  Renderer -> StateVar (V4 Word8)
rendererDrawColor Renderer
renderer StateVar (V4 Word8) -> V4 Word8 -> TwirlMonad ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
V4 Word8
255 Word8
255 Word8
255 Word8
255
  Renderer -> TwirlMonad ()
forall (m :: * -> *). (Functor m, MonadIO m) => Renderer -> m ()
clear Renderer
renderer
  a -> TwirlMonad ()
drawFunction a
newState
  Renderer -> TwirlMonad ()
forall (m :: * -> *). MonadIO m => Renderer -> m ()
present Renderer
renderer
  if Bool
quitApp
    then InputState -> TwirlMonad ()
closeControllers InputState
newInputState
    else TwirlConfig a
-> a
-> InputState
-> Renderer
-> Double
-> FPSState
-> Window
-> TwirlMonad ()
forall a.
TwirlConfig a
-> a
-> InputState
-> Renderer
-> Double
-> FPSState
-> Window
-> TwirlMonad ()
appLoop TwirlConfig a
config a
newState InputState
newInputState Renderer
renderer Double
remainingAccumulator FPSState
newFPSState Window
window
 where
  updateState :: a -> InputState -> Double -> TwirlMonad (a, Double)
updateState a
previousState InputState
inputState Double
accumulator = do
    let timeStep :: Double
timeStep = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fps)
    if Double
accumulator Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
timeStep
      then do
        a
newState <- a -> InputState -> Double -> TwirlMonad a
updateFunction a
previousState InputState
inputState Double
timeStep
        a -> InputState -> Double -> TwirlMonad (a, Double)
updateState a
newState InputState
inputState (Double
accumulator Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
timeStep)
      else do
        (a, Double) -> TwirlMonad (a, Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
previousState, Double
accumulator)

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

sleepRemainingTime :: MonadIO m => FPSState -> m (FPSState, Double)
sleepRemainingTime :: forall (m :: * -> *). MonadIO m => FPSState -> m (FPSState, Double)
sleepRemainingTime fpsState :: FPSState
fpsState@FPSState{Int
frameCount :: Int
frameCount :: FPSState -> Int
frameCount, Double
resetTime :: Double
resetTime :: FPSState -> Double
resetTime, Double
secondsPerFrame :: Double
secondsPerFrame :: FPSState -> Double
secondsPerFrame, Double
lastTime :: Double
lastTime :: FPSState -> Double
lastTime, Bool
vsyncActive :: Bool
vsyncActive :: FPSState -> Bool
vsyncActive} = do
  Double
currentTime <- m Double
forall a (m :: * -> *). (Fractional a, MonadIO m) => m a
time
  let targetTime :: Double
targetTime = Double
resetTime Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frameCount) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
secondsPerFrame
      frameTime :: Double
frameTime = Double
currentTime Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
lastTime
  if Bool
vsyncActive
    then (FPSState, Double) -> m (FPSState, Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FPSState
fpsState{frameCount :: Int
frameCount = Int
frameCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, lastTime :: Double
lastTime = Double
currentTime}, Double
frameTime)
    else
      if Double
currentTime Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
targetTime
        then do
          let requestedDelay :: Int
requestedDelay = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ (Double
targetTime Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
currentTime) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
requestedDelay
          (FPSState, Double) -> m (FPSState, Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FPSState
fpsState{frameCount :: Int
frameCount = Int
frameCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, lastTime :: Double
lastTime = Double
currentTime}, Double
frameTime)
        else do
          (FPSState, Double) -> m (FPSState, Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FPSState
fpsState{frameCount :: Int
frameCount = Int
1, resetTime :: Double
resetTime = Double
currentTime, secondsPerFrame :: Double
secondsPerFrame = Double
secondsPerFrame, lastTime :: Double
lastTime = Double
currentTime}, Double
frameTime)

initFPSState :: Int -> Bool -> IO FPSState
initFPSState :: Int -> Bool -> IO FPSState
initFPSState Int
fps Bool
vsyncActive = do
  Double
startTime <- IO Double
forall a (m :: * -> *). (Fractional a, MonadIO m) => m a
time
  FPSState -> IO FPSState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FPSState -> IO FPSState) -> FPSState -> IO FPSState
forall a b. (a -> b) -> a -> b
$ Int -> Double -> Double -> Double -> Bool -> FPSState
FPSState Int
0 Double
startTime (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fps)) Double
startTime Bool
vsyncActive