first jump implementation

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

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

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
 

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

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

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

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

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

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

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)
 

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