pituicat/src/Scenes/Test.hs

266 lines
6.2 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test where
import Affection
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V
import Data.String
import Control.Concurrent.STM
import Control.Arrow ((***))
import Control.Monad (void)
import Linear
-- internal imports
import Types
import Classes
import Map
import Renderer as R
data Test = Test
{ testMap :: TMVar LevelMap
, testGraphics :: TMVar GLAssets
, testLoaded :: TVar Bool
, testStageSet :: TVar (V.Vector StageSet)
, testCast :: TVar (V.Vector Cast)
}
data GLAssets = GLAssets
{ glVA :: VertexArray
, glVB :: VertexBuffer
, glIB :: IndexBuffer
, glSP :: Shader
, glTx :: [Texture]
}
instance Scene Test where
initScene =
Test
<$> newEmptyTMVarIO
<*> newEmptyTMVarIO
<*> newTVarIO False
<*> newTVarIO V.empty
<*> newTVarIO V.empty
loadScene level progress = do
atomically $ do
void $ takeTMVar progress
putTMVar progress (0, "Loading test level...")
loadedMap <- constructMap testLevelDesc 0
atomically $ putTMVar (testMap level) loadedMap
void $ atomically $ do
void $ takeTMVar progress
putTMVar progress (0.5, "Loaded test level map!")
void $ atomically $ swapTVar (testLoaded level) True
let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
view = mkTransformationMat
(identity :: M33 GL.GLfloat)
(V3 0 ((-64) * 32 + 600) 0)
model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
vertexArray <- newVertexArray
bind vertexArray
vertexBuffer <- newVertexBuffer 1024
bind vertexBuffer
let vertices = VS.fromList (createQuad (V2 (400 - 16) (300 - 16)) 0)
write vertexBuffer 0 vertices
indexBuffer <- newIndexBuffer 1024
bind indexBuffer
let indices = VS.fromList [0, 1, 2, 2, 3, 0]
write indexBuffer 0 indices
addBuffer (undefined :: Vertex) vertexBuffer
(_, tex) <- newTexture "res/pituicat/pituicat.png" 1
bind tex
shader <- newShader
[ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
, ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
]
bind shader
setUniform shader "u_mvp" (projection !*! view !*! model)
setUniformList
shader
"u_textures"
(map
textureSlot
[ (tileMapTexture $ mapTileMap loadedMap)
, tex
]
)
let pituicat = Pituicat
(V2 400 1748)
(V2 0 0)
(V2 0 0)
100
tex
unbind vertexArray
unbind vertexBuffer
unbind indexBuffer
unbind tex
unbind shader
atomically $ do
putTMVar (testGraphics level)
(GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
modifyTVar (testStageSet level) (\set -> StageSet pituicat `V.cons` set)
writeTVar (testLoaded level) True
void $ atomically $ do
void $ takeTMVar progress
putTMVar progress (1, "Loaded graphics!")
isSceneLoaded = liftIO . readTVarIO . testLoaded
update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
onEvents _ _ = return ()
render level = liftIO $ do
(GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level)
(LevelMap layers _ _ tileMap _) <-
atomically (readTMVar $ testMap level)
logIO Debug "loaded level"
stageSet <- readTVarIO (testStageSet level)
cast <- readTVarIO (testCast level)
logIO Debug "Read stage set and cast"
let (indices, vertices) = populate layers stageSet cast
logIO Debug "Populated"
bind va
bind vb
bind ib
logIO Debug "Bound buffers"
write vb 0 vertices
logIO Debug ("Written " <> fromString (show $ VS.length vertices) <> " vertices")
write ib 0 (VS.map fromIntegral indices)
logIO Debug ("Written " <> fromString (show $ VS.length indices) <> " indices")
logIO Debug "Wrote buffers"
bind (tileMapTexture tileMap)
mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
R.draw va ib sh
logIO Debug "Drawn"
testLevelDesc :: LevelDescriptor
testLevelDesc = LevelDescriptor
[ (0, "res/maps/00_test/00_test.bmp")
]
0
"res/tiles/00_test/00_test.png"
(3, 3)
createQuad :: V2 GL.GLfloat -> Int -> [Vertex]
createQuad (V2 x y) index =
[ newVertex
(V3 x y 0)
(V4 0 0 0 1)
(V2 0 (1 - (50 / 1024)))
(fromIntegral index)
, newVertex
(V3 (x + 32) y 0)
(V4 0 0 0 1)
(V2 (50 / 1024) (1 - (50/1024)))
(fromIntegral index)
, newVertex
(V3 (x + 32) (y + 32) 0)
(V4 0 0 0 1)
(V2 (50 / 1024) 1)
(fromIntegral index)
, newVertex
(V3 x (y + 32) 0)
(V4 0 0 0 1)
(V2 0 1)
(fromIntegral index)
]
populate
:: V.Vector Layer
-> V.Vector StageSet
-> V.Vector Cast
-> (VS.Vector Word, VS.Vector Vertex)
populate layers props actors =
(VS.convert *** VS.convert) $ foldl
(\(is, vs) (num, l) ->
let propsHere = V.filter (\(StageSet s) -> residentLayer s == num) props
actorsHere = V.filter (\(Cast c) -> residentLayer c == num) actors
(pisRaw, pvs) = V.foldl
(\(ais, avs) (StageSet s) ->
let (nis, nvs) = toVertices s
in
( ais V.++ nis
, avs V.++ nvs)
)
(V.empty, V.empty)
propsHere
(cisRaw, cvs) = V.foldl
(\(ais, avs) (Cast c) ->
let (nis, nvs) = toVertices c
in
( ais V.++ nis
, avs V.++ nvs)
)
(V.empty, V.empty)
actorsHere
(lisRaw, lvs) = toVertices l
lis = V.map
(+ if null is then 0 else V.maximum is + 1)
lisRaw
pis = V.map
(+
if null (is V.++ lis)
then 0
else V.maximum (is V.++ lis) + 1)
pisRaw
cis = V.map
(+
if null (is V.++ lis V.++ pis)
then 0
else V.maximum (is V.++ lis V.++ pis) + 1)
cisRaw
in
( is V.++ lis V.++ pis V.++ cis
, vs V.++ lvs V.++ pvs V.++ cvs
)
)
(V.empty, V.empty)
(V.zip (V.fromList [0 ..]) layers)