split Scene 'Test' up in submodules per method and hunt warnings

This commit is contained in:
nek0 2021-01-11 10:33:20 +01:00
parent ecffdaf467
commit 5ec8901dd7
13 changed files with 320 additions and 266 deletions

View file

@ -44,6 +44,10 @@ executable pituicat
, Classes.Physics.Mass
, Classes.Physics.Collidible
, Scenes.Test
, Scenes.Test.Types
, Scenes.Test.Util
, Scenes.Test.Load
, Scenes.Test.Update
, Map
, StateMachine
, Renderer

View file

@ -4,8 +4,6 @@ module Classes.Graphics.Buffer where
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
import Foreign.Storable
-- internal imports

View file

@ -1,45 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test where
module Scenes.Test
( module Test
) where
import Affection as A
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]
}
import Scenes.Test.Types as Test
import Scenes.Test.Util as Test
import Scenes.Test.Load as Test
import Scenes.Test.Update as Test
instance Scene Test where
@ -51,130 +30,11 @@ instance Scene Test where
<*> 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 100 1948)
(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 (testCast level) (\cast -> Cast pituicat `V.cons` cast)
writeTVar (testLoaded level) True
void $ atomically $ do
void $ takeTMVar progress
putTMVar progress (1, "Loaded graphics!")
loadScene = load
isSceneLoaded = liftIO . readTVarIO . testLoaded
update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
-- Let all Actors update themselves and check for collisions
-- (Typeclasses rock!)
atomically $ do
lmap <- readTMVar (testMap level)
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
modifyTVar
(testCast level) $ \cast ->
let playedCast =
V.map
(\(Cast c) -> Cast (perform dt c))
cast
collidedCast =
(\(Cast c1) (Cast c2) ->
Cast $
if collisionCheck dt c1 c2
then collide c1 c2
else c1
)
<$> playedCast <*> playedCast
wallCast (Cast c) = Cast $
V.foldl
(\member tile ->
if collisionCheck dt member tile
then collide member tile
else member
)
c
layer
walledCast =
V.map wallCast collidedCast
in
V.map
(\(Cast c) -> Cast $
move dt c
)
walledCast
update = Test.update
onEvents _ _ = return ()
@ -200,87 +60,3 @@ instance Scene Test where
V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
V.mapM_ (\(Cast c) -> bindPropTexture c) cast
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 (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)

107
src/Scenes/Test/Load.hs Normal file
View file

@ -0,0 +1,107 @@
{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test.Load where
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V
import Control.Concurrent.STM
import Control.Monad (void)
import Linear
-- internal imports
import Types
import Classes
import Map
import Scenes.Test.Types
import Scenes.Test.Util
load
:: Test
-> TMVar Progress
-> IO ()
load 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 100 1948)
(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 (testCast level) (\cast -> Cast pituicat `V.cons` cast)
writeTVar (testLoaded level) True
void $ atomically $ do
void $ takeTMVar progress
putTMVar progress (1, "Loaded graphics!")

25
src/Scenes/Test/Types.hs Normal file
View file

@ -0,0 +1,25 @@
module Scenes.Test.Types where
import Control.Concurrent.STM
import qualified Data.Vector as V
-- internal imports
import Types
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]
}

60
src/Scenes/Test/Update.hs Normal file
View file

@ -0,0 +1,60 @@
{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test.Update where
import Affection
import Control.Concurrent.STM
import qualified Data.Vector as V
import Data.String (fromString)
-- internal imports
import Scenes.Test.Types
import Classes
import Types
update
:: Test
-> Double
-> Affection ()
update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
-- Let all Actors update themselves and check for collisions
-- (Typeclasses rock!)
atomically $ do
lmap <- readTMVar (testMap level)
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
modifyTVar
(testCast level) $ \cast ->
let playedCast =
V.map
(\(Cast c) -> Cast (perform dt c))
cast
collidedCast =
(\(Cast c1) (Cast c2) ->
Cast $
if collisionCheck dt c1 c2
then collide c1 c2
else c1
)
<$> playedCast <*> playedCast
wallCast (Cast c) = Cast $
V.foldl
(\member tile ->
if collisionCheck dt member tile
then collide member tile
else member
)
c
layer
walledCast =
V.map wallCast collidedCast
in
V.map
(\(Cast c) -> Cast $
move dt c
)
walledCast

99
src/Scenes/Test/Util.hs Normal file
View file

@ -0,0 +1,99 @@
module Scenes.Test.Util where
import qualified Graphics.Rendering.OpenGL as GL
import Linear
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Control.Arrow ((***))
-- internal imports
import Classes
import Types
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)

View file

@ -3,27 +3,19 @@
module Types.Graphics.Shader where
import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL as GLRaw
import Data.List as L
import Data.StateVar
import qualified Data.ByteString as B
import Data.Maybe (fromJust)
import Control.Concurrent.MVar
import Linear
import Foreign.Marshal.Utils (with)
import Foreign.Marshal.Array (withArray)
import Foreign.Storable
import Foreign.Ptr
-- internal imports
@ -54,7 +46,7 @@ data ShaderUniform = ShaderUniform
-- orphan instance to make linear's M44 uniforms
instance GL.Uniform (M44 GL.GLfloat) where
uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter
uniform (GL.UniformLocation ul) = makeStateVar getter setter
where
getter = error "cannot implement: get uniform M44 GLfloat"
-- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
@ -65,7 +57,7 @@ instance GL.Uniform (M44 GL.GLfloat) where
(V4 m n o p)) = do
mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat)
GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor
uniformv (GL.UniformLocation ul) count buf = error "can not implement uniformv for M44 GLfloat"
uniformv (GL.UniformLocation _) _ _ = error "can not implement uniformv for M44 GLfloat"
-- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
-- where
-- elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c

View file

@ -3,22 +3,11 @@ module Types.Graphics.VertexArray where
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
import qualified Data.Vector as V
import Foreign (sizeOf)
import Foreign.Ptr
import Control.Concurrent.STM
import Control.Monad (void)
import SDL (($=))
-- internal imports
import Classes.Graphics.Bindable
import Classes.Graphics.Buffer
import Types.Graphics.VertexBuffer
newtype VertexArray = VertexArray
{ vArrId :: GL.VertexArrayObject
@ -29,7 +18,7 @@ instance Bindable VertexArray where
bind va = GL.bindVertexArrayObject $= Just (vArrId va)
unbind va = GL.bindVertexArrayObject $= Nothing
unbind _ = GL.bindVertexArrayObject $= Nothing
newVertexArray :: IO VertexArray
newVertexArray = VertexArray

View file

@ -29,9 +29,9 @@ instance Drawable Layer where
-- type VertexList Layer = V.Vector
toVertices vt = V.foldl
(\(acci, accv) (mult, a) ->
(\(acci, accv) (multi, a) ->
let (ris, vs) = toVertices a
is = V.map (mult * 4 +) ris
is = V.map (multi * 4 +) ris
in (acci V.++ is, accv V.++ vs)
)
(V.empty, V.empty)

View file

@ -108,4 +108,4 @@ instance Collidible Pituicat where
Debug
("*boing* meow! other: " <>
fromString (show other))
(elasticCollision 0.3 cat other)
(elasticCollision 0.9 cat other)

View file

@ -13,10 +13,14 @@ data Subsystems = Subsystems
, subTranslator :: SubTranslator
}
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
newtype SubWindow =
SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
newtype SubMouse =
SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype SubKeyboard =
SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype SubTranslator =
SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
data TranslatorMessage = TranslatorMessage
{ tmAction :: Action

View file

@ -1,6 +1,6 @@
module Types.Texture where
import SDL (($=), get)
import SDL (($=))
import qualified Graphics.Rendering.OpenGL as GL