first jump implementation

This commit is contained in:
nek0 2021-01-12 00:51:58 +01:00
parent 1e71b63f67
commit e820437bdf
11 changed files with 164 additions and 36 deletions

View File

@ -48,9 +48,11 @@ executable pituicat
, Scenes.Test.Util , Scenes.Test.Util
, Scenes.Test.Load , Scenes.Test.Load
, Scenes.Test.Update , Scenes.Test.Update
, Scenes.Test.EventHandler
, Map , Map
, StateMachine , StateMachine
, Renderer , Renderer
, Util
-- other-extensions: -- other-extensions:
build-depends: base >=4.13.0.0 build-depends: base >=4.13.0.0
, affection , affection

View File

@ -25,6 +25,7 @@ import Linear
import StateMachine() import StateMachine()
import Types import Types
import Classes import Classes
import Util
import Scenes.Test import Scenes.Test
instance Affectionate GameData where instance Affectionate GameData where
@ -58,26 +59,38 @@ main = do
preLoad :: GameData -> Affection () preLoad :: GameData -> Affection ()
preLoad gd = do preLoad gd = do
void $ partSubscribe translatorUUID <- partSubscribe
(subKeyboard $ gameSubsystems gd) (subKeyboard $ gameSubsystems gd)
(\(MsgKeyboardEvent time win motion False keysym) -> do (\mesg ->
translator <- liftIO $ atomically $ readTVar (gameActionTranslation gd) case mesg of
case (MsgKeyboardEvent time win motion False keysym) -> do
((SDL.keysymScancode keysym, SDL.keysymModifier keysym) `M.lookup` translator <- liftIO $ atomically $ readTVar (gameActionTranslation gd)
translator) case
of ((SDL.keysymScancode keysym, SDL.keysymModifier keysym) `M.lookup`
Just action -> translator)
partEmit of
(subTranslator $ gameSubsystems gd) Just action ->
(TranslatorMessage action time motion) partEmit
Nothing -> (subTranslator $ gameSubsystems gd)
return () (TranslatorMessage action time motion)
Nothing ->
globalKeyHandle gd mesg
_ ->
return ()
) )
void $ partSubscribe windowCloseUUID <- partSubscribe
(subWindow $ gameSubsystems gd) (subWindow $ gameSubsystems gd)
(\(MsgWindowClose time win) -> (\mesg -> case mesg of
atomically $ writeTVar (gameRunning gd) False 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 :: GameData -> [SDL.EventPayload] -> Affection ()
handle gd evs = do handle gd evs = do
@ -86,8 +99,9 @@ handle gd evs = do
update :: GameData -> Double -> Affection () update :: GameData -> Double -> Affection ()
update gd dt = do update gd dt = do
liftIO ((logIO Verbose) =<< (atomically $ loadProgress <- liftIO $ atomically $ readTMVar $ gameStateLoadProgress gd
(("Progress: " <>) . snd) <$> (readTMVar $ gameStateLoadProgress gd))) when (fst loadProgress < 1) $
liftIO (logIO Verbose ("Progress: " <> snd loadProgress))
state <- liftIO $ atomically $ readTVar $ gameState gd state <- liftIO $ atomically $ readTVar $ gameState gd
isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd
if isStagePresent if isStagePresent
@ -99,6 +113,10 @@ update gd dt = do
then do then do
liftIO $ logIO Verbose "Loading scene" liftIO $ logIO Verbose "Loading scene"
smLoad state gd smLoad state gd
evHandler <- partSubscribe
(subTranslator $ gameSubsystems gd)
(onEvents sceneContainer)
liftIO $ atomically $ writeTVar (gameSceneClean gd) (Just evHandler)
else else
smUpdate state gd dt smUpdate state gd dt
else else
@ -128,7 +146,9 @@ init = do
<*> (SubKeyboard <$> newTVarIO []) <*> (SubKeyboard <$> newTVarIO [])
<*> (SubTranslator <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO [])
) )
<*> newTVarIO (M.fromList []) <*> newTVarIO defaultTranslation
<*> newTVarIO True <*> newTVarIO True
<*> newTVarIO Nothing <*> newTVarIO Nothing
<*> newTVarIO Nothing <*> newTVarIO Nothing
<*> newTVarIO []
<*> newTVarIO Nothing

View File

@ -8,6 +8,8 @@ import Affection as A
import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Maybe (fromJust)
import Control.Concurrent.STM import Control.Concurrent.STM
-- internal imports -- internal imports
@ -19,6 +21,7 @@ import Scenes.Test.Types as Test
import Scenes.Test.Util as Test import Scenes.Test.Util as Test
import Scenes.Test.Load as Test import Scenes.Test.Load as Test
import Scenes.Test.Update as Test import Scenes.Test.Update as Test
import Scenes.Test.EventHandler as Test
instance Scene Test where instance Scene Test where
@ -27,8 +30,10 @@ instance Scene Test where
<$> newEmptyTMVarIO <$> newEmptyTMVarIO
<*> newEmptyTMVarIO <*> newEmptyTMVarIO
<*> newTVarIO False <*> newTVarIO False
<*> newTVarIO Nothing
<*> newTVarIO V.empty <*> newTVarIO V.empty
<*> newTVarIO V.empty <*> newTVarIO V.empty
<*> newTVarIO []
loadScene = load loadScene = load
@ -36,7 +41,7 @@ instance Scene Test where
update = Test.update update = Test.update
onEvents _ _ = return () onEvents = singleHandler
render level = liftIO $ do render level = liftIO $ do
(GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level) (GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level)
@ -44,7 +49,9 @@ instance Scene Test where
atomically (readTMVar $ testMap level) atomically (readTMVar $ testMap level)
stageSet <- readTVarIO (testStageSet 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 let (indices, vertices) = populate layers stageSet cast

View File

@ -1,16 +1,39 @@
{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test.EventHandler where module Scenes.Test.EventHandler where
import Affection import Affection as A
import qualified SDL import qualified SDL
import Linear
import Control.Concurrent.STM
import Data.String (fromString)
-- internal imports -- internal imports
import Classes import Classes
import Types import Types
import Scenes.Test.Types
singleHandler singleHandler
:: Test :: Test
:: Action -> TranslatorMessage
-> Affection () -> 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
)

View File

@ -4,7 +4,6 @@ module Scenes.Test.Load where
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V
import Control.Concurrent.STM import Control.Concurrent.STM
@ -89,6 +88,7 @@ load level progress = do
(V2 0 0) (V2 0 0)
100 100
tex tex
False
unbind vertexArray unbind vertexArray
unbind vertexBuffer unbind vertexBuffer
@ -99,7 +99,7 @@ load level progress = do
atomically $ do atomically $ do
putTMVar (testGraphics level) putTMVar (testGraphics level)
(GLAssets vertexArray vertexBuffer indexBuffer shader [tex]) (GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
modifyTVar (testCast level) (\cast -> Cast pituicat `V.cons` cast) writeTVar (testPlayer level) (Just pituicat)
writeTVar (testLoaded level) True writeTVar (testLoaded level) True
void $ atomically $ do void $ atomically $ do

View File

@ -1,5 +1,7 @@
module Scenes.Test.Types where module Scenes.Test.Types where
import Affection
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Data.Vector as V import qualified Data.Vector as V
@ -9,11 +11,13 @@ import qualified Data.Vector as V
import Types import Types
data Test = Test data Test = Test
{ testMap :: TMVar LevelMap { testMap :: TMVar LevelMap
, testGraphics :: TMVar GLAssets , testGraphics :: TMVar GLAssets
, testLoaded :: TVar Bool , testLoaded :: TVar Bool
, testPlayer :: TVar (Maybe Pituicat)
, testStageSet :: TVar (V.Vector StageSet) , testStageSet :: TVar (V.Vector StageSet)
, testCast :: TVar (V.Vector Cast) , testCast :: TVar (V.Vector Cast)
, testClean :: TVar [UUID]
} }
data GLAssets = GLAssets data GLAssets = GLAssets

View File

@ -9,6 +9,8 @@ import qualified Data.Vector as V
import Data.String (fromString) import Data.String (fromString)
import Data.Maybe (fromJust)
-- internal imports -- internal imports
import Scenes.Test.Types import Scenes.Test.Types
@ -58,3 +60,26 @@ update level dt = liftIO $ do
move dt c move dt c
) )
walledCast 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

View File

@ -1,6 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
module Types.Application where module Types.Application where
import Affection
import qualified SDL import qualified SDL
import Control.Concurrent (ThreadId) import Control.Concurrent (ThreadId)
@ -22,6 +24,8 @@ data GameData = GameData
, gameRunning :: TVar Bool , gameRunning :: TVar Bool
, gameLoadThread :: TVar (Maybe ThreadId) , gameLoadThread :: TVar (Maybe ThreadId)
, gameLoadContext :: TVar (Maybe SDL.GLContext) , gameLoadContext :: TVar (Maybe SDL.GLContext)
, gameGeneralClean :: TVar [UUID]
, gameSceneClean :: TVar (Maybe UUID)
} }
-- Existential type wrapper to make all Scenes implementing Scene -- Existential type wrapper to make all Scenes implementing Scene

View File

@ -26,12 +26,13 @@ data Pituicat = Pituicat
, pcAcc :: V2 Double , pcAcc :: V2 Double
, pcHealth :: Int , pcHealth :: Int
, pcTexture :: Texture , pcTexture :: Texture
, pcGrounded :: Bool
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Drawable Pituicat where instance Drawable Pituicat where
toVertices (Pituicat (V2 x y) _ _ _ _) = toVertices (Pituicat (V2 x y) _ _ _ _ _) =
( V.fromList [0, 1, 2, 2, 3, 0] ( V.fromList [0, 1, 2, 2, 3, 0]
, V.fromList , V.fromList
[ newVertex [ newVertex
@ -65,8 +66,15 @@ instance Prop Pituicat where
instance Actor Pituicat where instance Actor Pituicat where
perform dt p = (A.log Debug ("moving from " <> fromString (show $ pcPos p))) perform dt p =
(move dt . accelerate dt . gravitate (V2 0 (-250))) (p {pcAcc = 0}) 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 instance Mass Pituicat where
@ -108,4 +116,10 @@ instance Collidible Pituicat where
Debug Debug
("*boing* meow! other: " <> ("*boing* meow! other: " <>
fromString (show 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
}
)

View File

@ -25,9 +25,9 @@ newtype SubTranslator =
SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())]) SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
data TranslatorMessage = TranslatorMessage data TranslatorMessage = TranslatorMessage
{ tmAction :: Action { tmAction :: Action
, tmTime :: Double , tmTime :: Double
, tmKeyMotiuon :: SDL.InputMotion , tmKeyMotion :: SDL.InputMotion
} }
deriving (Eq, Show) deriving (Eq, Show)

29
src/Util.hs Normal file
View File

@ -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 ()