first jump implementation
This commit is contained in:
parent
1e71b63f67
commit
e820437bdf
|
@ -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
|
||||||
|
|
58
src/Main.hs
58
src/Main.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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 ()
|
Loading…
Reference in New Issue