split Scene 'Test' up in submodules per method and hunt warnings
This commit is contained in:
parent
ecffdaf467
commit
5ec8901dd7
13 changed files with 320 additions and 266 deletions
|
@ -44,6 +44,10 @@ executable pituicat
|
||||||
, Classes.Physics.Mass
|
, Classes.Physics.Mass
|
||||||
, Classes.Physics.Collidible
|
, Classes.Physics.Collidible
|
||||||
, Scenes.Test
|
, Scenes.Test
|
||||||
|
, Scenes.Test.Types
|
||||||
|
, Scenes.Test.Util
|
||||||
|
, Scenes.Test.Load
|
||||||
|
, Scenes.Test.Update
|
||||||
, Map
|
, Map
|
||||||
, StateMachine
|
, StateMachine
|
||||||
, Renderer
|
, Renderer
|
||||||
|
|
|
@ -4,8 +4,6 @@ module Classes.Graphics.Buffer where
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
import SDL (($=), get)
|
|
||||||
|
|
||||||
import Foreign.Storable
|
import Foreign.Storable
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
|
@ -1,45 +1,24 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Scenes.Test where
|
module Scenes.Test
|
||||||
|
( module Test
|
||||||
|
) where
|
||||||
|
|
||||||
import Affection as A
|
import Affection as A
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
|
||||||
|
|
||||||
import qualified Data.Vector.Storable as VS
|
import qualified Data.Vector.Storable as VS
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
|
|
||||||
import Data.String
|
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
|
|
||||||
import Control.Arrow ((***))
|
|
||||||
|
|
||||||
import Control.Monad (void)
|
|
||||||
|
|
||||||
import Linear
|
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Types
|
import Types
|
||||||
import Classes
|
import Classes
|
||||||
import Map
|
|
||||||
import Renderer as R
|
import Renderer as R
|
||||||
|
import Scenes.Test.Types as Test
|
||||||
data Test = Test
|
import Scenes.Test.Util as Test
|
||||||
{ testMap :: TMVar LevelMap
|
import Scenes.Test.Load as Test
|
||||||
, testGraphics :: TMVar GLAssets
|
import Scenes.Test.Update as Test
|
||||||
, 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
|
instance Scene Test where
|
||||||
|
|
||||||
|
@ -51,130 +30,11 @@ instance Scene Test where
|
||||||
<*> newTVarIO V.empty
|
<*> newTVarIO V.empty
|
||||||
<*> newTVarIO V.empty
|
<*> newTVarIO V.empty
|
||||||
|
|
||||||
loadScene level progress = do
|
loadScene = load
|
||||||
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!")
|
|
||||||
|
|
||||||
|
|
||||||
isSceneLoaded = liftIO . readTVarIO . testLoaded
|
isSceneLoaded = liftIO . readTVarIO . testLoaded
|
||||||
|
|
||||||
update level dt = liftIO $ do
|
update = Test.update
|
||||||
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
|
|
||||||
|
|
||||||
onEvents _ _ = return ()
|
onEvents _ _ = return ()
|
||||||
|
|
||||||
|
@ -200,87 +60,3 @@ instance Scene Test where
|
||||||
V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
|
V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
|
||||||
V.mapM_ (\(Cast c) -> bindPropTexture c) cast
|
V.mapM_ (\(Cast c) -> bindPropTexture c) cast
|
||||||
R.draw va ib sh
|
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
107
src/Scenes/Test/Load.hs
Normal 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
25
src/Scenes/Test/Types.hs
Normal 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
60
src/Scenes/Test/Update.hs
Normal 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
99
src/Scenes/Test/Util.hs
Normal 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)
|
|
@ -3,27 +3,19 @@
|
||||||
|
|
||||||
module Types.Graphics.Shader where
|
module Types.Graphics.Shader where
|
||||||
|
|
||||||
import SDL (($=), get)
|
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
import qualified Graphics.GL as GLRaw
|
import qualified Graphics.GL as GLRaw
|
||||||
|
|
||||||
import Data.List as L
|
|
||||||
|
|
||||||
import Data.StateVar
|
import Data.StateVar
|
||||||
|
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
|
|
||||||
import Data.Maybe (fromJust)
|
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
import Foreign.Marshal.Utils (with)
|
|
||||||
import Foreign.Marshal.Array (withArray)
|
import Foreign.Marshal.Array (withArray)
|
||||||
import Foreign.Storable
|
import Foreign.Storable
|
||||||
import Foreign.Ptr
|
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
|
@ -54,7 +46,7 @@ data ShaderUniform = ShaderUniform
|
||||||
|
|
||||||
-- orphan instance to make linear's M44 uniforms
|
-- orphan instance to make linear's M44 uniforms
|
||||||
instance GL.Uniform (M44 GL.GLfloat) where
|
instance GL.Uniform (M44 GL.GLfloat) where
|
||||||
uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter
|
uniform (GL.UniformLocation ul) = makeStateVar getter setter
|
||||||
where
|
where
|
||||||
getter = error "cannot implement: get uniform M44 GLfloat"
|
getter = error "cannot implement: get uniform M44 GLfloat"
|
||||||
-- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
|
-- 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
|
(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)
|
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
|
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)
|
-- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
|
||||||
-- where
|
-- where
|
||||||
-- elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c
|
-- elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c
|
||||||
|
|
|
@ -3,22 +3,11 @@ module Types.Graphics.VertexArray where
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
import SDL (($=), get)
|
import SDL (($=))
|
||||||
|
|
||||||
import qualified Data.Vector as V
|
|
||||||
|
|
||||||
import Foreign (sizeOf)
|
|
||||||
import Foreign.Ptr
|
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
|
|
||||||
import Control.Monad (void)
|
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Classes.Graphics.Bindable
|
import Classes.Graphics.Bindable
|
||||||
import Classes.Graphics.Buffer
|
|
||||||
import Types.Graphics.VertexBuffer
|
|
||||||
|
|
||||||
newtype VertexArray = VertexArray
|
newtype VertexArray = VertexArray
|
||||||
{ vArrId :: GL.VertexArrayObject
|
{ vArrId :: GL.VertexArrayObject
|
||||||
|
@ -29,7 +18,7 @@ instance Bindable VertexArray where
|
||||||
|
|
||||||
bind va = GL.bindVertexArrayObject $= Just (vArrId va)
|
bind va = GL.bindVertexArrayObject $= Just (vArrId va)
|
||||||
|
|
||||||
unbind va = GL.bindVertexArrayObject $= Nothing
|
unbind _ = GL.bindVertexArrayObject $= Nothing
|
||||||
|
|
||||||
newVertexArray :: IO VertexArray
|
newVertexArray :: IO VertexArray
|
||||||
newVertexArray = VertexArray
|
newVertexArray = VertexArray
|
||||||
|
|
|
@ -29,9 +29,9 @@ instance Drawable Layer where
|
||||||
-- type VertexList Layer = V.Vector
|
-- type VertexList Layer = V.Vector
|
||||||
|
|
||||||
toVertices vt = V.foldl
|
toVertices vt = V.foldl
|
||||||
(\(acci, accv) (mult, a) ->
|
(\(acci, accv) (multi, a) ->
|
||||||
let (ris, vs) = toVertices 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)
|
in (acci V.++ is, accv V.++ vs)
|
||||||
)
|
)
|
||||||
(V.empty, V.empty)
|
(V.empty, V.empty)
|
||||||
|
|
|
@ -108,4 +108,4 @@ instance Collidible Pituicat where
|
||||||
Debug
|
Debug
|
||||||
("*boing* meow! other: " <>
|
("*boing* meow! other: " <>
|
||||||
fromString (show other))
|
fromString (show other))
|
||||||
(elasticCollision 0.3 cat other)
|
(elasticCollision 0.9 cat other)
|
||||||
|
|
|
@ -13,10 +13,14 @@ data Subsystems = Subsystems
|
||||||
, subTranslator :: SubTranslator
|
, subTranslator :: SubTranslator
|
||||||
}
|
}
|
||||||
|
|
||||||
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
|
newtype SubWindow =
|
||||||
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
|
SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
|
||||||
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
newtype SubMouse =
|
||||||
newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
|
SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
|
||||||
|
newtype SubKeyboard =
|
||||||
|
SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
||||||
|
newtype SubTranslator =
|
||||||
|
SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
|
||||||
|
|
||||||
data TranslatorMessage = TranslatorMessage
|
data TranslatorMessage = TranslatorMessage
|
||||||
{ tmAction :: Action
|
{ tmAction :: Action
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
module Types.Texture where
|
module Types.Texture where
|
||||||
|
|
||||||
import SDL (($=), get)
|
import SDL (($=))
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue