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
|
2020-12-14 07:00:06 +00:00
|
|
|
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
|
|
|
|
|
2020-12-16 17:57:37 +00:00
|
|
|
import Control.Arrow ((***))
|
|
|
|
|
2020-10-28 10:48:58 +00:00
|
|
|
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
|
2020-12-16 17:57:37 +00:00
|
|
|
, testStageSet :: TVar (V.Vector StageSet)
|
|
|
|
, testCast :: TVar (V.Vector Cast)
|
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-23 06:47:20 +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
|
2020-12-14 07:00:06 +00:00
|
|
|
<*> newTVarIO V.empty
|
2020-12-16 17:57:37 +00:00
|
|
|
<*> 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
|
2020-12-14 07:00:06 +00:00
|
|
|
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
|
|
|
|
|
2020-12-14 07:00:06 +00:00
|
|
|
(_, 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-23 06:47:20 +00:00
|
|
|
setUniformList
|
|
|
|
shader
|
|
|
|
"u_textures"
|
|
|
|
(map
|
|
|
|
((\(GL.TextureObject o) -> o) . textureId)
|
|
|
|
[ (tileMapTexture $ mapTileMap loadedMap)
|
|
|
|
, tex
|
|
|
|
]
|
|
|
|
)
|
|
|
|
|
|
|
|
let pituicat = Pituicat
|
|
|
|
(V2 0 (-1748))
|
|
|
|
(V2 0 0)
|
|
|
|
(V2 0 0)
|
|
|
|
100
|
|
|
|
tex
|
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-23 06:47:20 +00:00
|
|
|
(GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
|
|
|
|
modifyTVar (testStageSet level) (\set -> StageSet pituicat `V.cons` set)
|
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
|
|
|
|
2020-12-23 06:47:20 +00:00
|
|
|
isSceneLoaded = liftIO . readTVarIO . testLoaded
|
2020-10-28 10:48:58 +00:00
|
|
|
|
2020-12-14 07:00:06 +00:00
|
|
|
update level dt = liftIO $ do
|
|
|
|
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
|
2020-12-16 17:57:37 +00:00
|
|
|
|
|
|
|
|
|
|
|
onEvents _ _ = return ()
|
|
|
|
|
|
|
|
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
|
|
|
logIO Debug "loaded level"
|
|
|
|
|
|
|
|
stageSet <- readTVarIO (testStageSet level)
|
|
|
|
cast <- readTVarIO (testCast level)
|
|
|
|
|
|
|
|
logIO Debug "Read stage set and cast"
|
2020-12-16 17:57:37 +00:00
|
|
|
|
|
|
|
let (indices, vertices) = populate layers stageSet cast
|
|
|
|
|
2020-12-23 06:47:20 +00:00
|
|
|
logIO Debug "Populated"
|
|
|
|
|
2020-12-14 07:00:06 +00:00
|
|
|
bind va
|
|
|
|
bind vb
|
2020-12-23 06:47:20 +00:00
|
|
|
bind ib
|
2020-12-14 07:00:06 +00:00
|
|
|
|
2020-12-23 06:47:20 +00:00
|
|
|
logIO Debug "Bound buffers"
|
2020-12-14 07:00:06 +00:00
|
|
|
|
2020-12-23 06:47:20 +00:00
|
|
|
write vb 0 vertices
|
|
|
|
|
|
|
|
logIO Debug ("Written " <> fromString (show $ VS.length vertices) <> " vertices")
|
2020-12-14 07:00:06 +00:00
|
|
|
|
2020-12-16 17:57:37 +00:00
|
|
|
write ib 0 (VS.map fromIntegral indices)
|
2020-12-23 06:47:20 +00:00
|
|
|
|
|
|
|
logIO Debug ("Written " <> fromString (show $ VS.length vertices) <> " indices")
|
|
|
|
|
|
|
|
logIO Debug "Wrote buffers"
|
|
|
|
|
2020-12-14 07:00:06 +00:00
|
|
|
bind (tileMapTexture tileMap)
|
2020-12-23 06:47:20 +00:00
|
|
|
mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
|
2020-12-06 07:14:50 +00:00
|
|
|
R.draw va ib sh
|
2020-10-28 10:48:58 +00:00
|
|
|
|
2020-12-23 06:47:20 +00:00
|
|
|
logIO Debug "Drawn"
|
|
|
|
|
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
|
|
|
]
|
2020-12-16 17:57:37 +00:00
|
|
|
|
|
|
|
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)
|
2020-12-23 06:47:20 +00:00
|
|
|
propsHere
|
2020-12-16 17:57:37 +00:00
|
|
|
(cisRaw, cvs) = V.foldl
|
|
|
|
(\(ais, avs) (Cast c) ->
|
|
|
|
let (nis, nvs) = toVertices c
|
|
|
|
in
|
|
|
|
( ais V.++ nis
|
|
|
|
, avs V.++ nvs)
|
|
|
|
)
|
|
|
|
(V.empty, V.empty)
|
2020-12-23 06:47:20 +00:00
|
|
|
actorsHere
|
2020-12-16 17:57:37 +00:00
|
|
|
(lisRaw, lvs) = toVertices l
|
|
|
|
lis = V.map
|
|
|
|
(+ if null is then 0 else V.maximum is)
|
|
|
|
lisRaw
|
|
|
|
pis = V.map
|
|
|
|
(+
|
|
|
|
if null (is V.++ lis)
|
|
|
|
then 0
|
|
|
|
else V.maximum (is V.++ lis))
|
|
|
|
pisRaw
|
|
|
|
cis = V.map
|
|
|
|
(+
|
|
|
|
if null (is V.++ lis V.++ pis)
|
|
|
|
then 0
|
|
|
|
else V.maximum (is V.++ lis V.++ pis))
|
|
|
|
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)
|