2020-10-28 10:48:58 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2021-01-11 09:33:20 +00:00
|
|
|
module Scenes.Test
|
|
|
|
( module Test
|
|
|
|
) where
|
2020-10-28 10:48:58 +00:00
|
|
|
|
2021-01-02 12:32:20 +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
|
2020-12-14 07:00:06 +00:00
|
|
|
import qualified Data.Vector as V
|
|
|
|
|
2021-04-22 03:37:57 +00:00
|
|
|
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
|
2021-04-29 18:28:52 +00:00
|
|
|
import Graphics
|
2020-12-06 07:14:50 +00:00
|
|
|
import Renderer as R
|
2021-01-11 09:33:20 +00:00
|
|
|
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
|
2020-12-14 07:00:06 +00:00
|
|
|
<*> newTVarIO V.empty
|
2020-12-16 17:57:37 +00:00
|
|
|
<*> 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
|
|
|
|
2021-01-11 09:33:20 +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
|
|
|
|
2021-01-11 09:33:20 +00:00
|
|
|
update = Test.update
|
2020-12-16 17:57:37 +00:00
|
|
|
|
2021-01-11 23:51:58 +00:00
|
|
|
onEvents = singleHandler
|
2020-12-16 17:57:37 +00:00
|
|
|
|
|
|
|
render level = liftIO $ do
|
2020-12-14 07:00:06 +00:00
|
|
|
(GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level)
|
2020-12-16 17:57:37 +00:00
|
|
|
(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-04-22 03:37:57 +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.++
|
|
|
|
nonPlayerCast
|
2021-01-20 04:12:16 +00:00
|
|
|
playerPos@(V2 px py) = realToFrac <$> (pcPos $ fromJust pituicat)
|
|
|
|
|
|
|
|
atomically $ modifyTVar (testMatrices level) $ \pvm ->
|
|
|
|
pvm
|
|
|
|
{ pvmV = mkTransformationMat
|
|
|
|
identity
|
|
|
|
(V3 (400 - px) (300 - py) 0)
|
|
|
|
}
|
|
|
|
|
|
|
|
(PVM p v m) <- atomically $ readTVar (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
|
2020-12-16 17:57:37 +00:00
|
|
|
|
2020-12-14 07:00:06 +00:00
|
|
|
bind va
|
|
|
|
bind vb
|
2020-12-23 06:47:20 +00:00
|
|
|
bind ib
|
2021-04-22 03:37:57 +00:00
|
|
|
bind sh
|
2020-12-14 07:00:06 +00:00
|
|
|
|
2021-04-22 03:37:57 +00:00
|
|
|
setUniform sh "u_mvp" (p !*! v !*! m)
|
2020-12-23 06:47:20 +00:00
|
|
|
write vb 0 vertices
|
|
|
|
|
2020-12-16 17:57:37 +00:00
|
|
|
write ib 0 (VS.map fromIntegral indices)
|
2020-12-23 06:47:20 +00:00
|
|
|
|
2020-12-14 07:00:06 +00:00
|
|
|
bind (tileMapTexture tileMap)
|
2020-12-24 11:01:59 +00:00
|
|
|
V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
|
|
|
|
V.mapM_ (\(Cast c) -> bindPropTexture c) cast
|
2020-12-06 07:14:50 +00:00
|
|
|
R.draw va ib sh
|