{-# 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