From e820437bdf4c0756a579e33dcdaedf638478c382 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Jan 2021 00:51:58 +0100 Subject: [PATCH] first jump implementation --- pituicat.cabal | 2 ++ src/Main.hs | 58 ++++++++++++++++++++++----------- src/Scenes/Test.hs | 11 +++++-- src/Scenes/Test/EventHandler.hs | 29 +++++++++++++++-- src/Scenes/Test/Load.hs | 4 +-- src/Scenes/Test/Types.hs | 10 ++++-- src/Scenes/Test/Update.hs | 25 ++++++++++++++ src/Types/Application.hs | 4 +++ src/Types/Player.hs | 22 ++++++++++--- src/Types/Subsystems.hs | 6 ++-- src/Util.hs | 29 +++++++++++++++++ 11 files changed, 164 insertions(+), 36 deletions(-) create mode 100644 src/Util.hs diff --git a/pituicat.cabal b/pituicat.cabal index 28a4641..3215b23 100644 --- a/pituicat.cabal +++ b/pituicat.cabal @@ -48,9 +48,11 @@ executable pituicat , Scenes.Test.Util , Scenes.Test.Load , Scenes.Test.Update + , Scenes.Test.EventHandler , Map , StateMachine , Renderer + , Util -- other-extensions: build-depends: base >=4.13.0.0 , affection diff --git a/src/Main.hs b/src/Main.hs index bacf903..5c7c5c0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,6 +25,7 @@ import Linear import StateMachine() import Types import Classes +import Util import Scenes.Test instance Affectionate GameData where @@ -58,26 +59,38 @@ main = do preLoad :: GameData -> Affection () preLoad gd = do - void $ partSubscribe + translatorUUID <- partSubscribe (subKeyboard $ gameSubsystems gd) - (\(MsgKeyboardEvent time win motion False keysym) -> do - translator <- liftIO $ atomically $ readTVar (gameActionTranslation gd) - case - ((SDL.keysymScancode keysym, SDL.keysymModifier keysym) `M.lookup` - translator) - of - Just action -> - partEmit - (subTranslator $ gameSubsystems gd) - (TranslatorMessage action time motion) - Nothing -> - return () + (\mesg -> + case mesg of + (MsgKeyboardEvent time win motion False keysym) -> do + translator <- liftIO $ atomically $ readTVar (gameActionTranslation gd) + case + ((SDL.keysymScancode keysym, SDL.keysymModifier keysym) `M.lookup` + translator) + of + Just action -> + partEmit + (subTranslator $ gameSubsystems gd) + (TranslatorMessage action time motion) + Nothing -> + globalKeyHandle gd mesg + _ -> + return () ) - void $ partSubscribe + windowCloseUUID <- partSubscribe (subWindow $ gameSubsystems gd) - (\(MsgWindowClose time win) -> - atomically $ writeTVar (gameRunning gd) False + (\mesg -> case mesg of + MsgWindowClose time win -> + liftIO $ atomically $ writeTVar (gameRunning gd) False + MsgWindowResize _ _ _ -> + fitViewport (800 / 600) mesg + _ -> + return () ) + liftIO $ atomically $ writeTVar + (gameGeneralClean gd) + [translatorUUID, windowCloseUUID] handle :: GameData -> [SDL.EventPayload] -> Affection () handle gd evs = do @@ -86,8 +99,9 @@ handle gd evs = do update :: GameData -> Double -> Affection () update gd dt = do - liftIO ((logIO Verbose) =<< (atomically $ - (("Progress: " <>) . snd) <$> (readTMVar $ gameStateLoadProgress gd))) + loadProgress <- liftIO $ atomically $ readTMVar $ gameStateLoadProgress gd + when (fst loadProgress < 1) $ + liftIO (logIO Verbose ("Progress: " <> snd loadProgress)) state <- liftIO $ atomically $ readTVar $ gameState gd isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd if isStagePresent @@ -99,6 +113,10 @@ update gd dt = do then do liftIO $ logIO Verbose "Loading scene" smLoad state gd + evHandler <- partSubscribe + (subTranslator $ gameSubsystems gd) + (onEvents sceneContainer) + liftIO $ atomically $ writeTVar (gameSceneClean gd) (Just evHandler) else smUpdate state gd dt else @@ -128,7 +146,9 @@ init = do <*> (SubKeyboard <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO []) ) - <*> newTVarIO (M.fromList []) + <*> newTVarIO defaultTranslation <*> newTVarIO True <*> newTVarIO Nothing <*> newTVarIO Nothing + <*> newTVarIO [] + <*> newTVarIO Nothing diff --git a/src/Scenes/Test.hs b/src/Scenes/Test.hs index fc26dba..102a3bb 100644 --- a/src/Scenes/Test.hs +++ b/src/Scenes/Test.hs @@ -8,6 +8,8 @@ import Affection as A import qualified Data.Vector.Storable as VS import qualified Data.Vector as V +import Data.Maybe (fromJust) + import Control.Concurrent.STM -- internal imports @@ -19,6 +21,7 @@ import Scenes.Test.Types as Test import Scenes.Test.Util as Test import Scenes.Test.Load as Test import Scenes.Test.Update as Test +import Scenes.Test.EventHandler as Test instance Scene Test where @@ -27,8 +30,10 @@ instance Scene Test where <$> newEmptyTMVarIO <*> newEmptyTMVarIO <*> newTVarIO False + <*> newTVarIO Nothing <*> newTVarIO V.empty <*> newTVarIO V.empty + <*> newTVarIO [] loadScene = load @@ -36,7 +41,7 @@ instance Scene Test where update = Test.update - onEvents _ _ = return () + onEvents = singleHandler render level = liftIO $ do (GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level) @@ -44,7 +49,9 @@ instance Scene Test where atomically (readTMVar $ testMap level) stageSet <- readTVarIO (testStageSet level) - cast <- readTVarIO (testCast level) + nonPlayerCast <- readTVarIO (testCast level) + pituicat <- atomically $ readTVar (testPlayer level) + let cast = Cast (fromJust pituicat) `V.cons` nonPlayerCast let (indices, vertices) = populate layers stageSet cast diff --git a/src/Scenes/Test/EventHandler.hs b/src/Scenes/Test/EventHandler.hs index 9fddc93..88fd41d 100644 --- a/src/Scenes/Test/EventHandler.hs +++ b/src/Scenes/Test/EventHandler.hs @@ -1,16 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} module Scenes.Test.EventHandler where -import Affection +import Affection as A import qualified SDL +import Linear + +import Control.Concurrent.STM + +import Data.String (fromString) + -- internal imports import Classes import Types +import Scenes.Test.Types singleHandler :: Test - :: Action + -> TranslatorMessage -> Affection () -singleHandler level event = return () +singleHandler level event = do + let multiplier = if tmKeyMotion event == SDL.Pressed then 1 else 0 + liftIO $ atomically $ modifyTVar (testPlayer level) (\(Just pituicat) -> + A.log Debug ("Grounded: " <> fromString (show $ pcGrounded pituicat)) $ + case tmAction event of + Jump -> if multiplier > 0 && pcGrounded pituicat + then A.log Debug "jumping" + (Just pituicat + { pcVel = pcVel pituicat + V2 0 250 + , pcGrounded = False + } + ) + else + Just pituicat + _ -> Just pituicat + ) diff --git a/src/Scenes/Test/Load.hs b/src/Scenes/Test/Load.hs index 06c9b61..4a9c4c8 100644 --- a/src/Scenes/Test/Load.hs +++ b/src/Scenes/Test/Load.hs @@ -4,7 +4,6 @@ module Scenes.Test.Load where import qualified Graphics.Rendering.OpenGL as GL import qualified Data.Vector.Storable as VS -import qualified Data.Vector as V import Control.Concurrent.STM @@ -89,6 +88,7 @@ load level progress = do (V2 0 0) 100 tex + False unbind vertexArray unbind vertexBuffer @@ -99,7 +99,7 @@ load level progress = do atomically $ do putTMVar (testGraphics level) (GLAssets vertexArray vertexBuffer indexBuffer shader [tex]) - modifyTVar (testCast level) (\cast -> Cast pituicat `V.cons` cast) + writeTVar (testPlayer level) (Just pituicat) writeTVar (testLoaded level) True void $ atomically $ do diff --git a/src/Scenes/Test/Types.hs b/src/Scenes/Test/Types.hs index c0c941b..64281cd 100644 --- a/src/Scenes/Test/Types.hs +++ b/src/Scenes/Test/Types.hs @@ -1,5 +1,7 @@ module Scenes.Test.Types where +import Affection + import Control.Concurrent.STM import qualified Data.Vector as V @@ -9,11 +11,13 @@ import qualified Data.Vector as V import Types data Test = Test - { testMap :: TMVar LevelMap + { testMap :: TMVar LevelMap , testGraphics :: TMVar GLAssets - , testLoaded :: TVar Bool + , testLoaded :: TVar Bool + , testPlayer :: TVar (Maybe Pituicat) , testStageSet :: TVar (V.Vector StageSet) - , testCast :: TVar (V.Vector Cast) + , testCast :: TVar (V.Vector Cast) + , testClean :: TVar [UUID] } data GLAssets = GLAssets diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index eb9faf4..f2c6308 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -9,6 +9,8 @@ import qualified Data.Vector as V import Data.String (fromString) +import Data.Maybe (fromJust) + -- internal imports import Scenes.Test.Types @@ -58,3 +60,26 @@ update level dt = liftIO $ do move dt c ) walledCast + updatedCast <- readTVar (testCast level) + modifyTVar + (testPlayer level) $ \(Just pituicat) -> + let playedCat = perform dt pituicat + collidedCat = + V.foldl + (\cat (Cast c) -> + if collisionCheck dt cat c + then collide cat c + else cat + ) + playedCat + updatedCast + walledCat = + V.foldl + (\cat tile -> + if collisionCheck dt cat tile + then collide cat tile + else cat + ) + collidedCat + layer + in Just $ move dt walledCat diff --git a/src/Types/Application.hs b/src/Types/Application.hs index a3fd388..b2d660a 100644 --- a/src/Types/Application.hs +++ b/src/Types/Application.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-} module Types.Application where +import Affection + import qualified SDL import Control.Concurrent (ThreadId) @@ -22,6 +24,8 @@ data GameData = GameData , gameRunning :: TVar Bool , gameLoadThread :: TVar (Maybe ThreadId) , gameLoadContext :: TVar (Maybe SDL.GLContext) + , gameGeneralClean :: TVar [UUID] + , gameSceneClean :: TVar (Maybe UUID) } -- Existential type wrapper to make all Scenes implementing Scene diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 43a60c0..316af45 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -26,12 +26,13 @@ data Pituicat = Pituicat , pcAcc :: V2 Double , pcHealth :: Int , pcTexture :: Texture + , pcGrounded :: Bool } deriving (Eq, Show) instance Drawable Pituicat where - toVertices (Pituicat (V2 x y) _ _ _ _) = + toVertices (Pituicat (V2 x y) _ _ _ _ _) = ( V.fromList [0, 1, 2, 2, 3, 0] , V.fromList [ newVertex @@ -65,8 +66,15 @@ instance Prop Pituicat where instance Actor Pituicat where - perform dt p = (A.log Debug ("moving from " <> fromString (show $ pcPos p))) - (move dt . accelerate dt . gravitate (V2 0 (-250))) (p {pcAcc = 0}) + perform dt p = + let physCat = (accelerate dt . gravitate (V2 0 (-250))) + (p {pcAcc = 0}) + (V2 _ dy) = pcVel physCat + finalCat = physCat + { pcGrounded = pcGrounded physCat || (dy < 0 && abs dy < 1) + } + in + (A.log Debug ("moving with " <> fromString (show $ pcVel finalCat))) finalCat instance Mass Pituicat where @@ -108,4 +116,10 @@ instance Collidible Pituicat where Debug ("*boing* meow! other: " <> fromString (show other)) - (elasticCollision 0.9 cat other) + (let ncat = (elasticCollision 0.3 cat other) + (V2 _ dy) = pcVel ncat + in + ncat + { pcGrounded = dy > 0 && abs dy < 1 + } + ) diff --git a/src/Types/Subsystems.hs b/src/Types/Subsystems.hs index 80df311..d7551fd 100644 --- a/src/Types/Subsystems.hs +++ b/src/Types/Subsystems.hs @@ -25,9 +25,9 @@ newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())]) data TranslatorMessage = TranslatorMessage - { tmAction :: Action - , tmTime :: Double - , tmKeyMotiuon :: SDL.InputMotion + { tmAction :: Action + , tmTime :: Double + , tmKeyMotion :: SDL.InputMotion } deriving (Eq, Show) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 index 0000000..43d6bac --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,29 @@ +module Util where + +import Affection + +import qualified SDL +import qualified SDL.Internal.Numbered as SDL + +-- internal imports + +import Types + +globalKeyHandle + :: GameData + -> KeyboardMessage + -> Affection () +globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) = + case mesg of + MsgKeyboardEvent + _ + _ + SDL.Pressed + False + (SDL.Keysym SDL.ScancodeF11 _ mod) -> + if mod == SDL.fromNumber 0 + then + toggleScreen 0 + else + return () + _ -> return ()