pituicat/src/Scenes/Test.hs

188 lines
4.4 KiB
Haskell
Raw Normal View History

2020-10-28 10:48:58 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test where
import Affection
2020-10-30 06:38:18 +00:00
import qualified Graphics.Rendering.OpenGL as GL
2020-12-06 07:14:50 +00:00
import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V
import Data.String
2020-12-06 07:14:50 +00:00
2020-10-28 10:48:58 +00:00
import Control.Concurrent.STM
import Control.Monad (void)
2020-10-30 06:38:18 +00:00
import Linear
2020-10-28 10:48:58 +00:00
-- internal imports
import Types
2020-12-05 09:10:37 +00:00
import Classes
2020-12-06 07:14:50 +00:00
import Map
import Renderer as R
2020-10-28 10:48:58 +00:00
data Test = Test
{ testMap :: TMVar LevelMap
2020-12-06 07:14:50 +00:00
, testGraphics :: TMVar GLAssets
2020-10-28 10:48:58 +00:00
, testLoaded :: TVar Bool
, testProps :: TVar (V.Vector Prop)
2020-10-28 10:48:58 +00:00
}
2020-12-06 07:14:50 +00:00
data GLAssets = GLAssets
{ glVA :: VertexArray
, glVB :: VertexBuffer
, glIB :: IndexBuffer
, glSP :: Shader
2020-12-14 02:12:33 +00:00
, glTx :: Texture
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
<*> newTVarIO V.empty
2020-10-28 10:48:58 +00:00
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
2020-10-30 06:38:18 +00:00
putTMVar progress (0.5, "Loaded test level map!")
2020-10-28 10:48:58 +00:00
void $ atomically $ swapTVar (testLoaded level) True
2020-10-30 06:38:18 +00:00
let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
view = mkTransformationMat
(identity :: M33 GL.GLfloat)
(V3 0 ((-64) * 32 + 600) 0)
2020-10-30 06:38:18 +00:00
model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
vertexArray <- newVertexArray
2020-12-05 09:10:37 +00:00
bind vertexArray
2020-10-30 06:38:18 +00:00
2020-12-06 07:14:50 +00:00
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
2020-12-14 02:12:33 +00:00
bind tex
2020-12-06 07:14:50 +00:00
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)
2020-12-14 02:12:33 +00:00
setUniform shader "u_texture" (0 :: GL.GLint)
2020-12-06 07:14:50 +00:00
unbind vertexArray
unbind vertexBuffer
unbind indexBuffer
2020-12-14 02:12:33 +00:00
unbind tex
2020-12-06 07:14:50 +00:00
unbind shader
atomically $ do
putTMVar (testGraphics level)
2020-12-14 02:12:33 +00:00
(GLAssets vertexArray vertexBuffer indexBuffer shader tex)
2020-12-06 07:14:50 +00:00
writeTVar (testLoaded level) True
2020-10-30 06:38:18 +00:00
void $ atomically $ do
void $ takeTMVar progress
putTMVar progress (1, "Loaded graphics!")
2020-10-28 10:48:58 +00:00
isSceneLoaded = liftIO . atomically . readTVar . testLoaded
update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
(GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level)
(LevelMap layers _ _ tileMap _) <- atomically (readTMVar $ testMap level)
let (indices, vertices) = V.foldl
(\(acci, accv) a ->
let (ris, vs) = toVertices a
is = V.map
(\i -> i +
if V.null acci
then 0
else (maximum acci + 1)
)
ris
in (acci V.++ is, accv V.++ vs)
)
(V.empty, V.empty)
layers
bind va
bind vb
write vb 0 (VS.convert vertices)
bind ib
write ib 0 (VS.convert $ V.map fromIntegral indices)
2020-10-28 10:48:58 +00:00
onEvents _ _ = return ()
2020-12-06 07:14:50 +00:00
render level = liftIO $ do
2020-12-14 02:12:33 +00:00
(GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level)
(LevelMap layers _ _ tileMap _) <- atomically (readTMVar $ testMap level)
2020-12-14 02:12:33 +00:00
bind va
bind (tileMapTexture tileMap)
2020-12-06 07:14:50 +00:00
R.draw va ib sh
2020-10-28 10:48:58 +00:00
testLevelDesc :: LevelDescriptor
testLevelDesc = LevelDescriptor
[ (0, "res/maps/00_test/00_test.bmp")
]
0
"res/tiles/00_test/00_test.png"
(3, 3)
2020-12-06 07:14:50 +00:00
createQuad :: V2 GL.GLfloat -> Int -> [Vertex]
2020-12-14 02:12:33 +00:00
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)
2020-12-06 07:14:50 +00:00
]