This commit is contained in:
nek0 2021-07-09 19:39:50 +02:00
parent 26e6825d0e
commit 5567b515e8

View file

@ -10,7 +10,7 @@ import qualified SDL.Raw.Enum as SDL
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import Control.Monad (when, void) import Control.Monad (when, void, unless)
import Control.Concurrent.STM import Control.Concurrent.STM
@ -35,7 +35,7 @@ instance Affectionate GameData where
draw = Main.draw draw = Main.draw
loadState = Main.init loadState = Main.init
cleanUp _ = return () cleanUp _ = return ()
hasNextStep = liftIO . atomically . readTVar . gameRunning hasNextStep = liftIO . readTVarIO . gameRunning
main :: IO () main :: IO ()
main = do main = do
@ -63,14 +63,13 @@ preLoad gd = do
(subKeyboard $ gameSubsystems gd) (subKeyboard $ gameSubsystems gd)
(\mesg -> (\mesg ->
case mesg of case mesg of
(MsgKeyboardEvent time win motion False keysym) -> do (MsgKeyboardEvent time _ motion False keysym) -> do
translator <- liftIO $ atomically $ readTVar (gameActionTranslation gd) translator <- liftIO $ readTVarIO (gameActionTranslation gd)
case case
( ( SDL.keysymScancode keysym
( SDL.keysymScancode keysym , translateSDLModifiers (SDL.keysymModifier keysym)
, translateSDLModifiers (SDL.keysymModifier keysym) ) `M.lookup`
) `M.lookup` translator
translator)
of of
Just action -> Just action ->
partEmit partEmit
@ -84,9 +83,9 @@ preLoad gd = do
windowCloseUUID <- partSubscribe windowCloseUUID <- partSubscribe
(subWindow $ gameSubsystems gd) (subWindow $ gameSubsystems gd)
(\mesg -> case mesg of (\mesg -> case mesg of
MsgWindowClose time win -> MsgWindowClose _ _ ->
liftIO $ atomically $ writeTVar (gameRunning gd) False liftIO $ atomically $ writeTVar (gameRunning gd) False
MsgWindowResize _ _ _ -> MsgWindowResize {} ->
fitViewport (800 / 600) mesg fitViewport (800 / 600) mesg
_ -> _ ->
return () return ()
@ -97,7 +96,7 @@ preLoad gd = do
handle :: GameData -> [SDL.EventPayload] -> Affection () handle :: GameData -> [SDL.EventPayload] -> Affection ()
handle gd evs = do handle gd evs = do
state <- liftIO (atomically $ readTVar $ gameState gd) state <- liftIO (readTVarIO $ gameState gd)
smEvent state gd evs smEvent state gd evs
update :: GameData -> Double -> Affection () update :: GameData -> Double -> Affection ()
@ -105,7 +104,7 @@ update gd dt = do
loadProgress <- liftIO $ atomically $ readTMVar $ gameStateLoadProgress gd loadProgress <- liftIO $ atomically $ readTMVar $ gameStateLoadProgress gd
when (fst loadProgress < 1) $ when (fst loadProgress < 1) $
liftIO (logIO Verbose ("Progress: " <> snd loadProgress)) liftIO (logIO Verbose ("Progress: " <> snd loadProgress))
state <- liftIO $ atomically $ readTVar $ gameState gd state <- liftIO $ readTVarIO $ gameState gd
isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd
if isStagePresent if isStagePresent
then do then do
@ -127,12 +126,12 @@ update gd dt = do
draw :: GameData -> Affection () draw :: GameData -> Affection ()
draw gd = do draw gd = do
state <- liftIO (atomically $ readTVar $ gameState gd) state <- liftIO (readTVarIO $ gameState gd)
liftIO $ logIO Verbose (fromString $ "now drawing: " <> show state) liftIO $ logIO Verbose (fromString $ "now drawing: " <> show state)
GL.clearColor $= GL.Color4 0 0 0 1 GL.clearColor $= GL.Color4 0 0 0 1
smDraw state gd smDraw state gd
err <- SDL.get GL.errors err <- SDL.get GL.errors
when (not $ null err) (liftIO $ logIO Error ("loop errors: " <> fromString (show err))) unless (null err) (liftIO $ logIO Error ("loop errors: " <> fromString (show err)))
init :: IO GameData init :: IO GameData
init = do init = do
@ -140,7 +139,7 @@ init = do
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
GameData GameData
<$> (newTMVarIO =<< (Stage <$> (initScene :: IO Test))) <$> (newTMVarIO . Stage =<< (initScene :: IO Test))
<*> newTVarIO Loading <*> newTVarIO Loading
<*> newTMVarIO (0, "Ohai!") <*> newTMVarIO (0, "Ohai!")
<*> (Subsystems <*> (Subsystems