{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Play.Engine.Runner where
import qualified Data.Map as M
import Control.Monad.IO.Class (MonadIO)
import Control.Monad
import qualified SDL
import SDL.Vect (V2(..), V4(..))
import Control.Lens hiding (sets)
import Control.DeepSeq
import Control.Concurrent.STM.TQueue
import qualified Play.Engine.MySDL.MySDL as MySDL
import Play.Engine.Input
import Play.Engine.Types
import Play.Engine.Utils
import Play.Engine.Settings
import Play.Engine.Scene
runGame :: Settings -> Stack Scene -> IO ()
runGame sets w = do
putStrLn "Hello Game!"
_ <- run sets w
putStrLn "Goodbye."
run :: Settings -> Stack Scene -> IO ()
run settings stack = do
responsesQueue <- newTQueueIO
resources <- MySDL.initResources
void $ MySDL.withWindow "Game" (MySDL.myWindowConfig (V2 (winSize x) (winSize y))) $
flip MySDL.withRenderer
(\(window, ren) ->
MySDL.apploop
resources
responsesQueue
window
ren
(settings, stack)
update
(render (window, ren) . snd)
)
where
winSize l = fromIntegral $ settings ^. windowSize . l
update
:: [MySDL.Response]
-> [SDL.EventPayload]
-> (SDL.Scancode -> Bool)
-> (Settings, Stack Scene)
-> IO (Either [String] ([MySDL.Request], (Settings, Stack Scene)))
update responses payload isKeyPressed (settings, stack) = do
let
(keys, joykeys) = makeEvents (_keyStats settings) (_joyKeyStats settings) payload isKeyPressed (_keyMap settings)
toggleMuteFlag
| keyClicked' KeyM keys = not
| otherwise = id
toggleWindowScale
| keyClicked' KeyScale keys = \case
NormalWindow -> SmallWindow
SmallWindow -> NormalWindow
| otherwise = id
settings' = settings
& over muteMusic toggleMuteFlag
& over windowScale toggleWindowScale
& set keyStats keys
& set joyKeyStats joykeys
toggleMuteCmd
| settings' ^. muteMusic = (:) MySDL.MuteMusic
| not (settings' ^. muteMusic) = (:) MySDL.UnmuteMusic
| otherwise = id
toggleWindowScaleCmd
| keyClicked' KeyScale keys = case settings' ^. windowScale of
NormalWindow -> (:) $ MySDL.SetNormalWindowScale $ settings' ^. windowSize
SmallWindow -> (:) $ MySDL.SetSmallWindowScale $ settings' ^. windowSize
| otherwise = id
pure
. fmap (\(setts, (reqs, states)) -> (toggleWindowScaleCmd $ toggleMuteCmd reqs, (setts, states)))
. (joykeys `deepseq` keys `deepseq` runResult $! settings')
$ updateScenes (Input (M.unionWith max keys joykeys) responses) stack
render :: (SDL.Window, SDL.Renderer) -> Stack Scene -> IO ()
render (_, renderer) stack = do
SDL.rendererDrawBlendMode renderer SDL.$= SDL.BlendAlphaBlend
renderTopScene renderer stack
SDL.present renderer
setBGColorBlack :: MonadIO m => (SDL.Window, SDL.Renderer) -> m (SDL.Window, SDL.Renderer)
setBGColorBlack sdlStuff@(_, renderer) = do
void $ MySDL.setBGColor (V4 0 0 0 255) renderer
pure sdlStuff