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.Load
, Scenes.Test.Update
, Scenes.Test.EventHandler
, Map
, StateMachine
, Renderer
, Util
-- other-extensions:
build-depends: base >=4.13.0.0
, affection

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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