pituicat/src/Scenes/Test.hs

95 lines
2.2 KiB
Haskell
Raw Normal View History

2020-10-28 10:48:58 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test
( module Test
) where
2020-10-28 10:48:58 +00:00
import Affection as A
2020-10-28 10:48:58 +00:00
2021-01-20 04:12:16 +00:00
import Linear
2020-12-06 07:14:50 +00:00
import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V
import Data.String (fromString)
2021-01-11 23:51:58 +00:00
import Data.Maybe (fromJust)
2020-10-28 10:48:58 +00:00
import Control.Concurrent.STM
-- internal imports
import Types
2020-12-05 09:10:37 +00:00
import Classes
import Graphics
2020-12-06 07:14:50 +00:00
import Renderer as R
import Scenes.Test.Types as Test
import Scenes.Test.Util as Test
import Scenes.Test.Load as Test
import Scenes.Test.Update as Test
2021-01-11 23:51:58 +00:00
import Scenes.Test.EventHandler as Test
2020-12-06 07:14:50 +00:00
2020-10-28 10:48:58 +00:00
instance Scene Test where
2020-12-06 07:14:50 +00:00
initScene =
Test
<$> newEmptyTMVarIO
<*> newEmptyTMVarIO
<*> newTVarIO False
2021-01-11 23:51:58 +00:00
<*> newTVarIO Nothing
<*> newTVarIO V.empty
<*> newTVarIO V.empty
2021-04-20 02:19:54 +00:00
<*> newTVarIO V.empty
2021-01-20 04:12:16 +00:00
<*> newTVarIO (PVM identity identity identity)
2021-01-11 23:51:58 +00:00
<*> newTVarIO []
2020-10-28 10:48:58 +00:00
loadScene = load
2020-10-28 10:48:58 +00:00
2020-12-23 06:47:20 +00:00
isSceneLoaded = liftIO . readTVarIO . testLoaded
2020-10-28 10:48:58 +00:00
update = Test.update
2021-01-11 23:51:58 +00:00
onEvents = singleHandler
render level = liftIO $ do
2021-07-14 00:42:24 +00:00
(GLAssets va vb ib sh _) <- atomically (readTMVar $ testGraphics level)
(LevelMap layers _ _ tileMap _) <-
atomically (readTMVar $ testMap level)
2020-12-23 06:47:20 +00:00
stageSet <- readTVarIO (testStageSet level)
2021-01-11 23:51:58 +00:00
nonPlayerCast <- readTVarIO (testCast level)
2021-07-14 00:42:24 +00:00
powerups <- V.map Cast <$> readTVarIO (testPowerups level)
-- A.logIO A.Debug (fromString $ V.foldl (\acc (Cast p) -> acc ++ show p ++ " ") "" powerups)
2021-04-20 02:19:54 +00:00
pituicat <- readTVarIO (testPlayer level)
2021-04-28 14:35:51 +00:00
let cast = Cast (fromJust pituicat) `V.cons` powerups V.++
2021-07-14 00:42:24 +00:00
nonPlayerCast
(V2 px py) = realToFrac <$> pcPos (fromJust pituicat)
2021-01-20 04:12:16 +00:00
atomically $ modifyTVar (testMatrices level) $ \pvm ->
pvm
{ pvmV = mkTransformationMat
identity
(V3 (400 - px) (300 - py) 0)
}
2021-07-14 00:42:24 +00:00
(PVM p v m) <- readTVarIO (testMatrices level)
2020-12-23 06:47:20 +00:00
2021-04-20 02:19:54 +00:00
let (indices, vertices) = populate
layers
stageSet
cast
bind va
bind vb
2020-12-23 06:47:20 +00:00
bind ib
bind sh
setUniform sh "u_mvp" (p !*! v !*! m)
2020-12-23 06:47:20 +00:00
write vb 0 vertices
write ib 0 (VS.map fromIntegral indices)
2020-12-23 06:47:20 +00:00
bind (tileMapTexture tileMap)
2021-07-14 00:42:24 +00:00
V.mapM_(\(StageSet prop) -> bindPropTexture prop) stageSet
V.mapM_(\(Cast c) -> bindPropTexture c) cast
2020-12-06 07:14:50 +00:00
R.draw va ib sh