{-# LANGUAGE LambdaCase, TypeFamilies #-}
module Play.Engine.MySDL.MySDL where
import Data.Word (Word8, Word32)
import Data.Text (Text)
import Control.Exception (catch, SomeException(..))
import Control.Monad.Identity
import Control.Monad.IO.Class (MonadIO, liftIO)
import System.IO
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM.TQueue
import Control.Concurrent.STM
import Control.Concurrent.Async
import qualified Data.ByteString as BS
import qualified Data.Vector as V
import qualified Foreign.C.Types as C
import qualified Data.Map as M
import qualified Data.Text as T
import qualified SDL
import qualified SDL.Image as SDLI
import qualified SDL.Font as SDLF
import qualified SDL.Mixer as Mix
import SDL.Vect (V2(..), V4(..))
import Play.Engine.Types (Size)
import Play.Engine.Utils (scalePoint)
myWindowConfig :: V2 C.CInt -> SDL.WindowConfig
myWindowConfig size = SDL.defaultWindow { SDL.windowInitialSize = size }
withWindow :: Text -> SDL.WindowConfig -> (SDL.Window -> IO a) -> IO a
withWindow title winConf go = do
SDL.initializeAll
SDLI.initialize [minBound..maxBound]
SDLF.initialize
window <- SDL.createWindow title winConf
SDL.showWindow window
mJoystick <- getJoystick
result <- Mix.withAudio Mix.defaultAudio 256 $ do
go window
sequence_ $ SDL.closeJoystick <$> mJoystick
SDL.destroyWindow window
SDLI.quit
SDLF.quit
SDL.quit
pure result
withRenderer :: MonadIO m => SDL.Window -> ((SDL.Window, SDL.Renderer) -> m a) -> m a
withRenderer window go = do
renderer <- SDL.createRenderer window (-1)
$ SDL.RendererConfig
{ rendererType = SDL.AcceleratedRenderer
, rendererTargetTexture = False
}
go (window, renderer)
apploop
:: ResourcesT TVar
-> TQueue Response
-> SDL.Window
-> SDL.Renderer
-> a
-> ([Response] -> [SDL.EventPayload] -> (SDL.Scancode -> Bool) -> a -> IO (Either [String] ([Request], a)))
-> (a -> IO ())
-> IO a
apploop resources responsesQueue window renderer world update render = do
start <- SDL.ticks
events <- collectEvents
keyState <- SDL.getKeyboardState
responses <- fmap (maybe [] (:[])) $ atomically $ tryReadTQueue responsesQueue
update responses events keyState world >>= \case
Left errs ->
liftIO $ mapM (hPutStrLn stderr . ("*** Error: " ++)) errs >> pure world
Right (reqs, newWorld) -> do
render newWorld
void $ async $ mapConcurrently_ (runRequest resources responsesQueue window renderer) reqs
if checkEvent SDL.QuitEvent events
then pure world
else do
when (isWindowHidden events) $ do
isPlaying <- Mix.playingMusic
when isPlaying Mix.pauseMusic
let
loop evs
| isWindowExposed evs = when isPlaying Mix.resumeMusic
| otherwise = loop =<< collectEvents
loop events
end <- SDL.ticks
regulateFPS 60 start end
apploop resources responsesQueue window renderer newWorld update render
regulateFPS :: Word32 -> Word32 -> Word32 -> IO ()
regulateFPS fps start end
| fps == 0 = pure ()
| otherwise = do
let
ticksPerFrame = 1000 `div` fps
interval = end - start
gap = ticksPerFrame - interval
delayFor
| gap < ticksPerFrame =
fromIntegral $ max 0 gap
| otherwise =
fromIntegral ticksPerFrame
threadDelay $ delayFor * 1000
getJoystick :: IO (Maybe SDL.Joystick)
getJoystick = do
joysticks <- SDL.availableJoysticks
let
joystick =
if V.length joysticks == 0
then Nothing
else pure (joysticks V.! 0)
sequence $ SDL.openJoystick <$> joystick
setBGColor :: MonadIO m => V4 Word8 -> SDL.Renderer -> m SDL.Renderer
setBGColor color renderer = do
SDL.rendererDrawColor renderer SDL.$= color
SDL.clear renderer
pure renderer
collectEvents :: MonadIO m => m [SDL.EventPayload]
collectEvents = SDL.pollEvent >>= \case
Nothing -> pure []
Just e -> (SDL.eventPayload e :) <$> collectEvents
checkEvent :: SDL.EventPayload -> [SDL.EventPayload] -> Bool
checkEvent = elem
isWindowHidden :: [SDL.EventPayload] -> Bool
isWindowHidden = any $ \case
SDL.WindowHiddenEvent{} -> True
_ -> False
isWindowExposed :: [SDL.EventPayload] -> Bool
isWindowExposed = any $ \case
SDL.WindowExposedEvent{} -> True
_ -> False
data Resource
= RTexture SDL.Texture
| RFont SDLF.Font
| RMusic BS.ByteString
data ResourceType a
= Texture a
| Font a
| Music a
data Request
= Load ![(String, ResourceType FilePath)]
| DestroyTexture SDL.Texture
| MakeText (String, FilePath) T.Text
| PlayMusic (String, FilePath)
| MuteMusic
| UnmuteMusic
| SetNormalWindowScale Size
| SetSmallWindowScale Size
data Response
= ResourcesLoaded Resources
| NewText SDL.Texture
| Exception String
data ResourcesT f
= Resources
{ textures :: HKD f (M.Map FilePath SDL.Texture)
, fonts :: HKD f (M.Map FilePath SDLF.Font)
, music :: HKD f (M.Map FilePath BS.ByteString)
}
type family HKD f a where
HKD Identity a = a
HKD f a = f a
type Resources = ResourcesT Identity
initResources :: IO (ResourcesT TVar)
initResources =
Resources
<$> newTVarIO M.empty
<*> newTVarIO M.empty
<*> newTVarIO M.empty
runRequest :: ResourcesT TVar -> TQueue Response -> SDL.Window -> SDL.Renderer -> Request -> IO ()
runRequest resources queue window renderer req =
flip catch (\(SomeException e) -> atomically $ writeTQueue queue $ Exception $ show e) $
case req of
Load files -> do
results <-
mapConcurrently
(loadResource renderer resources)
files
atomically $ writeTQueue queue (resourcesToResponse results)
DestroyTexture txt ->
SDL.destroyTexture txt
MakeText (n, p) txt -> do
(_, RFont fnt) <- loadResource renderer resources (n, Font p)
text <- SDL.createTextureFromSurface renderer =<< SDLF.solid fnt (V4 255 255 255 255) txt
atomically $ writeTQueue queue $ NewText text
PlayMusic (n, p) -> do
(_, RMusic msc) <- loadResource renderer resources (n, Music p)
Mix.playMusic Mix.Forever =<< Mix.decode msc
MuteMusic -> do
Mix.setMusicVolume 0
UnmuteMusic -> do
Mix.setMusicVolume 100
SetSmallWindowScale size -> do
SDL.windowSize window SDL.$= (scalePoint 0.7 size)
SDL.rendererScale renderer SDL.$= 0.7
SDL.setWindowPosition window SDL.Centered
SetNormalWindowScale size -> do
SDL.windowSize window SDL.$= fmap fromIntegral size
SDL.rendererScale renderer SDL.$= 1
SDL.setWindowPosition window SDL.Centered
loadResource renderer resources (n, r) =
case r of
Texture (("assets/imgs/" ++) -> f) -> do
mTxt <- atomically $ do
txts <- readTVar (textures resources)
pure $ M.lookup f txts
(n,) . RTexture <$> case mTxt of
Just txt ->
pure txt
Nothing -> do
txt <- SDLI.loadTexture renderer f
atomically $ do
txts' <- readTVar (textures resources)
writeTVar (textures resources) (M.insert f txt txts')
pure txt
Font (("assets/fonts/" ++) -> f) -> do
mFont <- atomically $ do
fnts <- readTVar (fonts resources)
pure $ M.lookup f fnts
(n,) . RFont <$> case mFont of
Just fnt ->
pure fnt
Nothing -> do
fnt <- SDLF.load f 18
atomically $ do
fnts' <- readTVar (fonts resources)
writeTVar (fonts resources) (M.insert f fnt fnts')
pure fnt
Music (("assets/audio/" ++) -> f) -> do
mMusic <- atomically $ do
msc <- readTVar (music resources)
pure $ M.lookup f msc
(n,) . RMusic <$> case mMusic of
Just msc ->
pure msc
Nothing -> do
contents <- BS.readFile f
atomically $ do
msc' <- readTVar (music resources)
writeTVar (music resources) (M.insert f contents msc')
pure contents
resourcesToResponse :: [(String, Resource)] -> Response
resourcesToResponse rs =
ResourcesLoaded . foldr (flip g) initS $ rs
where
initS = Resources M.empty M.empty M.empty
g s = \case
(n, RTexture t) -> s { textures = M.insert n t (textures s) }
(n, RFont f) -> s { fonts = M.insert n f (fonts s) }
(n, RMusic m) -> s { music = M.insert n m (music s) }