{-# 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)