start collectables

pituicat.cabal

@@ -36,6 +36,7 @@ executable pituicat
                      , Classes.Scene
                      , Classes.Actor
                      , Classes.Prop
+                     , Classes.Collectable
                      , Classes.Graphics
                      , Classes.Graphics.Bindable
                      , Classes.Graphics.Buffer
@@ -44,7 +45,6 @@ executable pituicat
                      , Classes.Physics
                      , Classes.Physics.Mass
                      , Classes.Physics.Collidible
-                     , Classes.Physics.Collectable
                      , Scenes.Test
                      , Scenes.Test.Types
                      , Scenes.Test.Util

src/Classes.hs

@@ -7,3 +7,4 @@ import Classes.Scene as C
 import Classes.Prop as C
 import Classes.Actor as C
 import Classes.Physics as C
+import Classes.Collectable as C

src/Classes/Collectable.hs

@@ -1,4 +1,4 @@
-module Classes.Physics.Collectable where
+module Classes.Collectable where
 
 import Classes.Physics.Collidible (Collidible)
 
@@ -11,12 +11,14 @@ data Effect
   | Antidote
   | StopTime
   | Invisibility
+  deriving (Show)
 
 -- | The Effect holder type definition
 data EffectHolder = EffectHolder
   { effectDuration :: Double -- ^ Duration of stored effect
   , effectReleased :: Effect -- ^ The actual effect released
   }
+  deriving (Show)
 
 class Collidible c => Collectable c where
 

src/Scenes/Test.hs

@@ -35,6 +35,7 @@ instance Scene Test where
       <*> newTVarIO Nothing
       <*> newTVarIO V.empty
       <*> newTVarIO V.empty
+      <*> newTVarIO V.empty
       <*> newTVarIO (PVM identity identity identity)
       <*> newTVarIO []
 
@@ -53,8 +54,11 @@ instance Scene Test where
 
     stageSet <- readTVarIO (testStageSet level)
     nonPlayerCast <- readTVarIO (testCast level)
-    pituicat <- atomically $ readTVar (testPlayer level)
-    let cast = Cast (fromJust pituicat) `V.cons` nonPlayerCast
+    powerups <- fmap (V.map Cast) (readTVarIO (testPowerups level))
+    pituicat <- readTVarIO (testPlayer level)
+    let cast = Cast (fromJust pituicat) `V.cons` powerups
+         --  nonPlayerCast V.++
+         --  powerups
         playerPos@(V2 px py) = realToFrac <$> (pcPos $ fromJust pituicat)
 
     atomically $ modifyTVar (testMatrices level) $ \pvm ->
@@ -67,7 +71,10 @@ instance Scene Test where
     (PVM p v m) <- atomically $ readTVar (testMatrices level)
     setUniform sh "u_mvp" (p !*! v !*! m)
 
-    let (indices, vertices) = populate layers stageSet cast
+    let (indices, vertices) = populate
+          layers
+          stageSet
+          cast
 
     bind va
     bind vb

src/Scenes/Test/Load.hs

@@ -3,6 +3,7 @@ module Scenes.Test.Load where
 
 import qualified Graphics.Rendering.OpenGL as GL
 
+import qualified Data.Vector as V
 import qualified Data.Vector.Storable as VS
 
 import Control.Concurrent.STM
@@ -38,7 +39,7 @@ load level progress = do
 
   bind vertexArray
 
-  vertexBuffer <- newVertexBuffer 1024
+  vertexBuffer <- newVertexBuffer 4096
 
   bind vertexBuffer
 
@@ -80,6 +81,14 @@ load level progress = do
         tex
         False
         Nothing
+      oil = PowerUp
+        (realToFrac <$> (startpos) + V2 100 0)
+        (V2 0 0)
+        (V2 0 0)
+        5
+        tex
+        (EffectHolder 5 SpeedUp)
+
 
   bind shader
   setUniform shader "u_mvp" (projection !*! view !*! model)
@@ -103,6 +112,7 @@ load level progress = do
     putTMVar (testGraphics level)
       (GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
     writeTVar (testPlayer level) (Just pituicat)
+    writeTVar (testPowerups level) (V.fromList [oil])
     writeTVar (testLoaded level) True
     writeTVar (testMatrices level) (PVM projection view model)
 

src/Scenes/Test/Types.hs

@@ -19,6 +19,7 @@ data Test = Test
   , testPlayer   :: TVar (Maybe Pituicat)
   , testStageSet :: TVar (V.Vector StageSet)
   , testCast     :: TVar (V.Vector Cast)
+  , testPowerups :: TVar (V.Vector PowerUp)
   , testMatrices :: TVar PVM
   , testClean    :: TVar [UUID]
   }

src/Scenes/Test/Update.hs

@@ -32,6 +32,11 @@ update level dt = liftIO $ do
   atomically $ do
     lmap <- readTMVar (testMap level)
     let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
+    modifyTVar (testPowerups level) $ \pus ->
+      let played = V.map (perform dt) pus
+          collided = V.map (\pu -> performWorldCollision pu layer dt) played
+      in
+        collided
     modifyTVar
       (testCast level) $ \cast ->
         let playedCast =

src/Types.hs

@@ -11,3 +11,4 @@ import Types.StageSet as T
 import Types.Graphics as T
 import Types.Player as T
 import Types.Util as T
+import Types.PowerUp as T

src/Types/Player.hs

@@ -79,7 +79,7 @@ instance Actor Pituicat where
     let (V2 _ dy) = velocity physCat
         physCat = (accelerate dt . gravitate constG)
           (p
-            { pcAcc = 0
+            { pcAcc = V2 0 0
             , pcTMoveVel =
               case pcMoveState p of
                 Just MoveRight -> V2 catMoveVelocity 0

src/Types/PowerUp.hs

@@ -0,0 +1,120 @@
+module Types.PowerUp where
+
+import qualified Data.Vector as V
+
+import Linear
+
+-- internal imports
+
+import Classes.Graphics.Drawable
+import Classes.Graphics.Bindable
+import Classes.Collectable
+import Classes.Prop
+import Classes.Actor
+import Classes.Physics
+
+import Types.Graphics.VertexBuffer
+import Types.Texture
+
+import Util
+
+data PowerUp = PowerUp
+  { puPos     :: V2 Double
+  , puVel     :: V2 Double
+  , puAcc     :: V2 Double
+  , puTTL     :: Double
+  , puTexture :: Texture
+  , puEffect  :: EffectHolder
+  }
+  deriving (Show)
+
+instance Drawable PowerUp where
+
+  toVertices (PowerUp (V2 x y) _ _ _ _ _) =
+    ( V.fromList [0, 1, 2, 2, 3, 0]
+    , V.fromList
+      [ newVertex
+        (V3 (realToFrac x - 20) (realToFrac y - 20) 0)
+        (V4 1 1 1 1)
+        (V2 0 (1 - 50 / 1024))
+        1
+      , newVertex
+        (V3 (realToFrac x + 20) (realToFrac y - 20) 0)
+        (V4 1 1 1 1)
+        (V2 (50 / 1024) (1 - 50 / 1024))
+        1
+      , newVertex
+        (V3 (realToFrac x + 20) (realToFrac y + 20) 0)
+        (V4 1 1 1 1)
+        (V2 (50 / 1024) 1)
+        1
+      , newVertex
+        (V3 (realToFrac x - 20) (realToFrac y + 20) 0)
+        (V4 1 1 1 1)
+        (V2 0 1)
+        1
+      ]
+    )
+
+instance Prop PowerUp where
+
+  residentLayer _ = 0
+
+  bindPropTexture = bind . puTexture
+
+instance Actor PowerUp where
+
+  perform dt o =
+    let phys = (accelerate dt . gravitate constG)
+          o
+            { puAcc = V2 0 0
+            , puTTL = puTTL o - dt
+            }
+    in
+      phys
+
+instance Mass PowerUp where
+
+  mass _ = 1
+
+  acceleration = puAcc
+
+  accelerationUpdater o =
+    (\acc -> o
+      { puAcc = acc
+      }
+      )
+
+  velocity = puVel
+
+  velocityUpdater o =
+    (\vel -> o
+      { puVel = vel
+      }
+      )
+
+  position = puPos
+
+  positionUpdater o =
+    (\pos -> o
+      { puPos = pos
+      }
+      )
+
+instance Collidible PowerUp where
+
+  boundary _ =
+    ( V2 (-20) (-20)
+    , V2 20 20
+    )
+
+  collide o _ NoCollision = o
+
+  collide o other collr@(Collision ddr (V2 dirx diry)) =
+    let no = elasticCollision 0.3 o other collr
+    in
+      no
+
+instance Collectable PowerUp where
+
+  effect = puEffect

src/Types/Tangible.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 module Types.Tangible where
 
-import Classes.Physics.Collectable (Collectable)
+import Classes.Collectable (Collectable)
 
 data Tangible = forall a . Collectable a => Tangible a