pituicat/src/Scenes/Test.hs

132 lines
3.1 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test where
import Affection
import SDL (($=), get)
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as VS
import Control.Concurrent.STM
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
}
data GLAssets = GLAssets
{ glVA :: VertexArray
, glVB :: VertexBuffer
, glIB :: IndexBuffer
, glSP :: Shader
}
instance Scene Test where
initScene =
Test
<$> newEmptyTMVarIO
<*> newEmptyTMVarIO
<*> newTVarIO False
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 0 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
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)
unbind vertexArray
unbind vertexBuffer
unbind indexBuffer
unbind shader
atomically $ do
putTMVar (testGraphics level)
(GLAssets vertexArray vertexBuffer indexBuffer shader)
writeTVar (testLoaded level) True
void $ atomically $ do
void $ takeTMVar progress
putTMVar progress (1, "Loaded graphics!")
isSceneLoaded = liftIO . atomically . readTVar . testLoaded
update _ _ = return ()
onEvents _ _ = return ()
render level = liftIO $ do
(GLAssets va vb ib sh) <- atomically (readTMVar $ testGraphics level)
bind vb
R.draw va ib sh
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 pos@(V2 x y) index =
[ newVertex (V3 x y 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
, newVertex (V3 (x + 32) y 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
, newVertex (V3 (x + 32) (y + 32) 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
, newVertex (V3 x (y + 32) 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
]