aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Demos/Pong/Main.hs110
-rw-r--r--Spear.cabal13
-rw-r--r--Spear/GL.hs13
-rw-r--r--Spear/Game.hs53
-rw-r--r--Spear/Math/Matrix3.hs6
-rw-r--r--Spear/Math/Matrix4.hs30
-rw-r--r--Spear/Math/Spatial3.hs6
-rw-r--r--Spear/Math/Vector/Vector3.hs2
-rw-r--r--Spear/Render/AnimatedModel.hs4
-rw-r--r--Spear/Render/Core.hs17
-rw-r--r--Spear/Render/Core/Buffer.hs122
-rw-r--r--Spear/Render/Core/Constants.hs12
-rw-r--r--Spear/Render/Core/Geometry.hs150
-rw-r--r--Spear/Render/Core/Pipeline.hs74
-rw-r--r--Spear/Render/Core/Shader.hs216
-rw-r--r--Spear/Render/Core/State.hs157
-rw-r--r--Spear/Render/Immediate.hs166
-rw-r--r--Spear/Render/StaticModel.hs4
-rw-r--r--Spear/Scene/Loader.hs12
-rw-r--r--Spear/Window.hs38
20 files changed, 1092 insertions, 113 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index ac0feab..c82b67e 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -1,31 +1,49 @@
1module Main where 1module Main where
2 2
3import Data.Maybe (mapMaybe)
4import Graphics.Rendering.OpenGL.GL (($=))
5import qualified Graphics.Rendering.OpenGL.GL as GL
6import Graphics.Rendering.OpenGL.GL.VertexSpec (currentColor)
7import Pong 3import Pong
4
8import Spear.App 5import Spear.App
9import Spear.Game 6import Spear.Game
10import Spear.Math.AABB 7import Spear.Math.AABB
8import Spear.Math.Matrix4 as Matrix4 hiding
9 (position)
11import Spear.Math.Spatial 10import Spear.Math.Spatial
12import Spear.Math.Spatial2 11import Spear.Math.Spatial2
13import Spear.Math.Vector 12import Spear.Math.Vector
13import Spear.Render.Core.Pipeline
14import Spear.Render.Core.State
15import Spear.Render.Immediate
14import Spear.Window 16import Spear.Window
15 17
18import Data.Maybe (mapMaybe)
19import Graphics.Rendering.OpenGL.GL (($=))
20import qualified Graphics.Rendering.OpenGL.GL as GL
21import Graphics.Rendering.OpenGL.GL.VertexSpec (currentColor)
22
23
16data GameState = GameState 24data GameState = GameState
17 { window :: Window, 25 { window :: Window
18 world :: [GameObject] 26 , renderCoreState :: RenderCoreState
27 , immRenderState :: ImmRenderState
28 , viewProjection :: Matrix4
29 , world :: [GameObject]
19 } 30 }
20 31
21app = App step render resize 32app = App step render resize
22 33
23main = 34main =
24 withWindow (900, 600) (2, 0) (Just "Pong") initGame $ 35 withWindow (900, 600) (Just "Pong") initGame endGame $
25 loop app 36 loop app
26 37
27initGame :: Window -> Game () GameState 38initGame :: Window -> Game () GameState
28initGame window = return $ GameState window newWorld 39initGame window = do
40 (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState
41 return $ GameState window renderCoreState immRenderState Matrix4.id newWorld
42
43endGame :: Game GameState ()
44endGame = do
45 game <- getGameState
46 runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
29 47
30step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool 48step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
31step elapsed dt inputEvents = do 49step elapsed dt inputEvents = do
@@ -38,47 +56,54 @@ step elapsed dt inputEvents = do
38 return (not $ exitRequested inputEvents) 56 return (not $ exitRequested inputEvents)
39 57
40render :: Game GameState () 58render :: Game GameState ()
41render = getGameState >>= \gs -> gameIO . render' $ world gs 59render = do
60 gameState <- getGameState
61 immRenderState' <- flip execSubGame (immRenderState gameState) $ do
62 immStart
63 immSetViewProjectionMatrix (viewProjection gameState)
64 -- Clear the background to a different colour than the playable area to make
65 -- the latter distinguishable.
66 gameIO $ do
67 setClearColour (0.2, 0.2, 0.2, 0.0)
68 clearBuffers [ColourBuffer]
69 render' $ world gameState
70 immEnd
71 saveGameState $ gameState { immRenderState = immRenderState' }
42 72
43render' :: [GameObject] -> IO () 73render' :: [GameObject] -> Game ImmRenderState ()
44render' world = do 74render' world = do
45 -- Clear the background to a different colour than the playable area to make 75 immLoadIdentity
46 -- the latter distinguishable.
47 GL.clearColor $= GL.Color4 0.2 0.2 0.2 0.0
48 GL.clear [GL.ColorBuffer]
49 GL.matrixMode $= GL.Modelview 0
50 GL.loadIdentity
51 renderBackground 76 renderBackground
52 -- Draw objects. 77 -- Draw objects.
53 GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 78 immSetColour (vec4 1.0 1.0 1.0 1.0)
54 mapM_ renderGO world 79 mapM_ renderGO world
55 80
56renderBackground :: IO () 81renderBackground :: Game ImmRenderState ()
57renderBackground = 82renderBackground =
58 let pmin = 0 :: Float 83 let pmin = 0 :: Float
59 pmax = 1 :: Float 84 pmax = 1 :: Float
60 in do 85 in do
61 GL.currentColor $= GL.Color4 0.7 0.5 0.7 1.0 86 immSetColour (vec4 0.6 0.35 0.6 1.0)
62 GL.renderPrimitive GL.TriangleStrip $ do 87 immDrawQuads2d [
63 GL.vertex (GL.Vertex2 pmin pmax) 88 (vec2 pmin pmin
64 GL.vertex (GL.Vertex2 pmin pmin) 89 ,vec2 pmax pmin
65 GL.vertex (GL.Vertex2 pmax pmax) 90 ,vec2 pmax pmax
66 GL.vertex (GL.Vertex2 pmax pmin) 91 ,vec2 pmin pmax)]
67 92
68renderGO :: GameObject -> IO () 93renderGO :: GameObject -> Game ImmRenderState ()
69renderGO go = do 94renderGO go = do
70 let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go 95 let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go
71 (Vector2 xcenter ycenter) = position go 96 (Vector2 xcenter ycenter) = position go
72 (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') 97 immPreservingMatrix $ do
73 GL.preservingMatrix $ do 98 immTranslate (vec3 xcenter ycenter 0)
74 GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) 99 immDrawQuads2d [
75 GL.renderPrimitive GL.TriangleStrip $ do 100 (vec2 xmin ymin
76 GL.vertex (GL.Vertex2 xmin ymax) 101 ,vec2 xmax ymin
77 GL.vertex (GL.Vertex2 xmin ymin) 102 ,vec2 xmax ymax
78 GL.vertex (GL.Vertex2 xmax ymax) 103 ,vec2 xmin ymax)]
79 GL.vertex (GL.Vertex2 xmax ymin) 104
80 105-- TODO: Fix the resize hang.
81resize :: WindowEvent -> Game s () 106resize :: WindowEvent -> Game GameState ()
82resize (ResizeEvent w h) = 107resize (ResizeEvent w h) =
83 let r = fromIntegral w / fromIntegral h 108 let r = fromIntegral w / fromIntegral h
84 pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 109 pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
@@ -86,12 +111,11 @@ resize (ResizeEvent w h) =
86 right = if r > 1 then 1 + pad else 1 111 right = if r > 1 then 1 + pad else 1
87 bottom = if r > 1 then 0 else -pad 112 bottom = if r > 1 then 0 else -pad
88 top = if r > 1 then 1 else 1 + pad 113 top = if r > 1 then 1 else 1 + pad
89 in gameIO $ do 114 in do
90 GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) 115 gameIO $ setViewport 0 0 w h
91 GL.matrixMode $= GL.Projection 116 modifyGameState $ \state -> state {
92 GL.loadIdentity 117 viewProjection = Matrix4.ortho left right bottom top (-1) 1
93 GL.ortho left right bottom top (-1) 1 118 }
94 GL.matrixMode $= GL.Modelview 0
95 119
96translateEvents = mapMaybe translateEvents' 120translateEvents = mapMaybe translateEvents'
97 where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft 121 where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft
diff --git a/Spear.cabal b/Spear.cabal
index 40b625d..b044ae2 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -21,6 +21,8 @@ library
21 bytestring -any, 21 bytestring -any,
22 directory -any, 22 directory -any,
23 exceptions -any, 23 exceptions -any,
24 hashable -any,
25 hashmap -any,
24 mtl -any, 26 mtl -any,
25 transformers -any, 27 transformers -any,
26 resourcet -any, 28 resourcet -any,
@@ -62,6 +64,14 @@ library
62 Spear.Math.Vector.Vector4 64 Spear.Math.Vector.Vector4
63 Spear.Prelude 65 Spear.Prelude
64 Spear.Render.AnimatedModel 66 Spear.Render.AnimatedModel
67 Spear.Render.Core
68 Spear.Render.Core.Buffer
69 Spear.Render.Core.Constants
70 Spear.Render.Core.Geometry
71 Spear.Render.Core.Pipeline
72 Spear.Render.Core.Shader
73 Spear.Render.Core.State
74 Spear.Render.Immediate
65 Spear.Render.Material 75 Spear.Render.Material
66 Spear.Render.Model 76 Spear.Render.Model
67 Spear.Render.Program 77 Spear.Render.Program
@@ -105,7 +115,7 @@ library
105 Spear/Assets/Model/Model_error_code.h 115 Spear/Assets/Model/Model_error_code.h
106 Spear/Assets/Model/sys_types.h 116 Spear/Assets/Model/sys_types.h
107 Spear/Render/RenderModel.h 117 Spear/Render/RenderModel.h
108 Timer/timer.h 118 Spear/Sys/Timer/timer.h
109 119
110 include-dirs: 120 include-dirs:
111 . 121 .
@@ -113,6 +123,7 @@ library
113 Spear/Assets/Image 123 Spear/Assets/Image
114 Spear/Assets/Image/BMP 124 Spear/Assets/Image/BMP
115 Spear/Assets/Model 125 Spear/Assets/Model
126 Spear/Contrib/glad/include/
116 Spear/Render 127 Spear/Render
117 Spear/Sys 128 Spear/Sys
118 129
diff --git a/Spear/GL.hs b/Spear/GL.hs
index 81a433e..f463109 100644
--- a/Spear/GL.hs
+++ b/Spear/GL.hs
@@ -87,6 +87,13 @@ module Spear.GL
87 ) 87 )
88where 88where
89 89
90import Spear.Assets.Image
91import Spear.Game
92import Spear.Math.Algebra
93import Spear.Math.Matrix3 (Matrix3)
94import Spear.Math.Matrix4 (Matrix4)
95import Spear.Math.Vector
96
90import Control.Monad 97import Control.Monad
91import Control.Monad.Trans.Class 98import Control.Monad.Trans.Class
92import Control.Monad.Trans.State as State 99import Control.Monad.Trans.State as State
@@ -103,12 +110,6 @@ import Foreign.Storable
103import Foreign.Storable (peek) 110import Foreign.Storable (peek)
104import Graphics.GL.Core46 111import Graphics.GL.Core46
105import Prelude hiding ((*)) 112import Prelude hiding ((*))
106import Spear.Assets.Image
107import Spear.Game
108import Spear.Math.Algebra
109import Spear.Math.Matrix3 (Matrix3)
110import Spear.Math.Matrix4 (Matrix4)
111import Spear.Math.Vector
112import System.Directory (doesFileExist, getCurrentDirectory, 113import System.Directory (doesFileExist, getCurrentDirectory,
113 setCurrentDirectory) 114 setCurrentDirectory)
114import System.IO (hPutStrLn, stderr) 115import System.IO (hPutStrLn, stderr)
diff --git a/Spear/Game.hs b/Spear/Game.hs
index e43974f..14e3f20 100644
--- a/Spear/Game.hs
+++ b/Spear/Game.hs
@@ -11,7 +11,8 @@ module Spear.Game
11 11
12 -- * Game resources 12 -- * Game resources
13 register, 13 register,
14 unregister, 14 release,
15 release',
15 16
16 -- * Error handling 17 -- * Error handling
17 gameError, 18 gameError,
@@ -21,11 +22,15 @@ module Spear.Game
21 22
22 -- * Running and IO 23 -- * Running and IO
23 runGame, 24 runGame,
24 runGame', 25 evalGame,
25 runSubGame, 26 runSubGame,
26 runSubGame', 27 runSubGame',
27 evalSubGame, 28 evalSubGame,
28 execSubGame, 29 execSubGame,
30 runSiblingGame,
31 runSiblingGame',
32 evalSiblingGame,
33 execSiblingGame,
29 gameIO, 34 gameIO,
30 ) 35 )
31where 36where
@@ -35,23 +40,19 @@ import Control.Monad.State.Strict
35import Control.Monad.Trans.Class (lift) 40import Control.Monad.Trans.Class (lift)
36import qualified Control.Monad.Trans.Resource as R 41import qualified Control.Monad.Trans.Resource as R
37 42
38type Resource = R.ReleaseKey
39 43
40type Game s = StateT s (R.ResourceT IO) 44type Resource = R.ReleaseKey
41 45
42class ResourceClass a where 46class ResourceClass a where
43 getResource :: a -> Resource 47 getResource :: a -> Resource
44 48
45 release :: a -> Game s () 49type Game s = StateT s (R.ResourceT IO)
46 release = unregister . getResource
47
48 clean :: a -> IO ()
49 clean = R.release . getResource
50 50
51newtype GameException = GameException String deriving (Show) 51newtype GameException = GameException String deriving (Show)
52 52
53instance Exception GameException 53instance Exception GameException
54 54
55
55-- | Retrieve the game state. 56-- | Retrieve the game state.
56getGameState :: Game s s 57getGameState :: Game s s
57getGameState = get 58getGameState = get
@@ -69,8 +70,12 @@ register :: IO () -> Game s Resource
69register = lift . R.register 70register = lift . R.register
70 71
71-- | Release the given 'Resource'. 72-- | Release the given 'Resource'.
72unregister :: Resource -> Game s () 73release :: ResourceClass a => a -> Game s ()
73unregister = lift . R.release 74release = lift . R.release . getResource
75
76-- | Release the given 'Resource'.
77release' :: ResourceClass a => a -> IO ()
78release' = R.release . getResource
74 79
75-- | Throw an error from the 'Game' monad. 80-- | Throw an error from the 'Game' monad.
76gameError :: String -> Game s a 81gameError :: String -> Game s a
@@ -97,9 +102,9 @@ catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError'
97runGame :: Game s a -> s -> IO (a, s) 102runGame :: Game s a -> s -> IO (a, s)
98runGame game = R.runResourceT . runStateT game 103runGame game = R.runResourceT . runStateT game
99 104
100-- | Run the given game and discard its state. 105-- | Run the given game and return its result.
101runGame' :: Game s a -> s -> IO a 106evalGame :: Game s a -> s -> IO a
102runGame' g s = fst <$> runGame g s 107evalGame g s = fst <$> runGame g s
103 108
104-- | Fully run the given sub game, unrolling the entire monad stack. 109-- | Fully run the given sub game, unrolling the entire monad stack.
105runSubGame :: Game s a -> s -> Game t (a, s) 110runSubGame :: Game s a -> s -> Game t (a, s)
@@ -109,14 +114,30 @@ runSubGame g s = gameIO $ runGame g s
109runSubGame' :: Game s a -> s -> Game t () 114runSubGame' :: Game s a -> s -> Game t ()
110runSubGame' g s = void $ runSubGame g s 115runSubGame' g s = void $ runSubGame g s
111 116
112-- | Run the given game and return its result. 117-- | Run the given sub game and return its result.
113evalSubGame :: Game s a -> s -> Game t a 118evalSubGame :: Game s a -> s -> Game t a
114evalSubGame g s = fst <$> runSubGame g s 119evalSubGame g s = fst <$> runSubGame g s
115 120
116-- | Run the given game and return its state. 121-- | Run the given sub game and return its state.
117execSubGame :: Game s a -> s -> Game t s 122execSubGame :: Game s a -> s -> Game t s
118execSubGame g s = snd <$> runSubGame g s 123execSubGame g s = snd <$> runSubGame g s
119 124
125-- | Run the given sibling game, unrolling StateT but not ResourceT.
126runSiblingGame :: Game s a -> s -> Game t (a, s)
127runSiblingGame g s = lift $ runStateT g s
128
129-- | Like 'runSiblingGame', but discarding the result.
130runSiblingGame' :: Game s a -> s -> Game t ()
131runSiblingGame' g s = void $ runSiblingGame g s
132
133-- | Run the given sibling game and return its result.
134evalSiblingGame :: Game s a -> s -> Game t a
135evalSiblingGame g s = fst <$> runSiblingGame g s
136
137-- | Run the given sibling game and return its state.
138execSiblingGame :: Game s a -> s -> Game t s
139execSiblingGame g s = snd <$> runSiblingGame g s
140
120-- | Perform the given IO action in the 'Game' monad. 141-- | Perform the given IO action in the 'Game' monad.
121gameIO :: IO a -> Game s a 142gameIO :: IO a -> Game s a
122gameIO = lift . lift 143gameIO = lift . lift
diff --git a/Spear/Math/Matrix3.hs b/Spear/Math/Matrix3.hs
index c8ed6d2..3493d63 100644
--- a/Spear/Math/Matrix3.hs
+++ b/Spear/Math/Matrix3.hs
@@ -25,7 +25,7 @@ module Spear.Math.Matrix3
25, translate 25, translate
26, translatev 26, translatev
27 -- ** Rotation 27 -- ** Rotation
28, rot 28, rotate
29 -- ** Scale 29 -- ** Scale
30, Spear.Math.Matrix3.scale 30, Spear.Math.Matrix3.scale
31, scalev 31, scalev
@@ -209,8 +209,8 @@ translatev v = mat3
209-- | Create a rotation matrix rotating counter-clockwise about the Z axis. 209-- | Create a rotation matrix rotating counter-clockwise about the Z axis.
210-- 210--
211-- The given angle must be in degrees. 211-- The given angle must be in degrees.
212rot :: Float -> Matrix3 212rotate :: Float -> Matrix3
213rot angle = mat3 213rotate angle = mat3
214 c (-s) 0 214 c (-s) 0
215 s c 0 215 s c 0
216 0 0 1 216 0 0 1
diff --git a/Spear/Math/Matrix4.hs b/Spear/Math/Matrix4.hs
index bc74a27..225bb0e 100644
--- a/Spear/Math/Matrix4.hs
+++ b/Spear/Math/Matrix4.hs
@@ -24,12 +24,12 @@ module Spear.Math.Matrix4
24, Spear.Math.Matrix4.id 24, Spear.Math.Matrix4.id
25 -- * Transformations 25 -- * Transformations
26 -- ** Translation 26 -- ** Translation
27, transl 27, translate
28, translv 28, translatev
29 -- ** Rotation 29 -- ** Rotation
30, rotX 30, rotateX
31, rotY 31, rotateY
32, rotZ 32, rotateZ
33, axisAngle 33, axisAngle
34 -- ** Scale 34 -- ** Scale
35, Spear.Math.Matrix4.scale 35, Spear.Math.Matrix4.scale
@@ -261,16 +261,16 @@ id = mat4
261 0 0 0 1 261 0 0 0 1
262 262
263-- | Create a translation matrix. 263-- | Create a translation matrix.
264transl :: Float -> Float -> Float -> Matrix4 264translate :: Float -> Float -> Float -> Matrix4
265transl x y z = mat4 265translate x y z = mat4
266 1 0 0 x 266 1 0 0 x
267 0 1 0 y 267 0 1 0 y
268 0 0 1 z 268 0 0 1 z
269 0 0 0 1 269 0 0 0 1
270 270
271-- | Create a translation matrix. 271-- | Create a translation matrix.
272translv :: Vector3 -> Matrix4 272translatev :: Vector3 -> Matrix4
273translv v = mat4 273translatev v = mat4
274 1 0 0 (x v) 274 1 0 0 (x v)
275 0 1 0 (y v) 275 0 1 0 (y v)
276 0 0 1 (z v) 276 0 0 1 (z v)
@@ -278,8 +278,8 @@ translv v = mat4
278 278
279-- | Create a rotation matrix rotating about the X axis. 279-- | Create a rotation matrix rotating about the X axis.
280-- The given angle must be in degrees. 280-- The given angle must be in degrees.
281rotX :: Float -> Matrix4 281rotateX :: Float -> Matrix4
282rotX angle = mat4 282rotateX angle = mat4
283 1 0 0 0 283 1 0 0 0
284 0 c (-s) 0 284 0 c (-s) 0
285 0 s c 0 285 0 s c 0
@@ -290,8 +290,8 @@ rotX angle = mat4
290 290
291-- | Create a rotation matrix rotating about the Y axis. 291-- | Create a rotation matrix rotating about the Y axis.
292-- The given angle must be in degrees. 292-- The given angle must be in degrees.
293rotY :: Float -> Matrix4 293rotateY :: Float -> Matrix4
294rotY angle = mat4 294rotateY angle = mat4
295 c 0 s 0 295 c 0 s 0
296 0 1 0 0 296 0 1 0 0
297 (-s) 0 c 0 297 (-s) 0 c 0
@@ -302,8 +302,8 @@ rotY angle = mat4
302 302
303-- | Create a rotation matrix rotating about the Z axis. 303-- | Create a rotation matrix rotating about the Z axis.
304-- The given angle must be in degrees. 304-- The given angle must be in degrees.
305rotZ :: Float -> Matrix4 305rotateZ :: Float -> Matrix4
306rotZ angle = mat4 306rotateZ angle = mat4
307 c (-s) 0 0 307 c (-s) 0 0
308 s c 0 0 308 s c 0 0
309 0 0 1 0 309 0 0 1 0
diff --git a/Spear/Math/Spatial3.hs b/Spear/Math/Spatial3.hs
index 0f804cc..5d4d4fb 100644
--- a/Spear/Math/Spatial3.hs
+++ b/Spear/Math/Spatial3.hs
@@ -43,9 +43,9 @@ instance Positional Transform3 Vector3 where
43 43
44instance Rotational Transform3 Vector3 Rotation3 where 44instance Rotational Transform3 Vector3 Rotation3 where
45 setRotation rotation _ = Transform3 $ case rotation of 45 setRotation rotation _ = Transform3 $ case rotation of
46 Pitch angle -> Matrix4.rotX angle 46 Pitch angle -> Matrix4.rotateX angle
47 Yaw angle -> Matrix4.rotY angle 47 Yaw angle -> Matrix4.rotateY angle
48 Roll angle -> Matrix4.rotZ angle 48 Roll angle -> Matrix4.rotateZ angle
49 AxisAngle axis angle -> Matrix4.axisAngle axis angle 49 AxisAngle axis angle -> Matrix4.axisAngle axis angle
50 RotationMatrix matrix -> matrix 50 RotationMatrix matrix -> matrix
51 51
diff --git a/Spear/Math/Vector/Vector3.hs b/Spear/Math/Vector/Vector3.hs
index 9d44c8b..db5dc45 100644
--- a/Spear/Math/Vector/Vector3.hs
+++ b/Spear/Math/Vector/Vector3.hs
@@ -168,7 +168,7 @@ sizeFloat = sizeOf (undefined :: CFloat)
168 168
169 169
170instance Storable Vector3 where 170instance Storable Vector3 where
171 sizeOf _ = (3::Int) * sizeFloat 171 sizeOf _ = sizeVector3
172 alignment _ = alignment (undefined :: CFloat) 172 alignment _ = alignment (undefined :: CFloat)
173 173
174 peek ptr = do 174 peek ptr = do
diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs
index 966fcc2..8f0d6bd 100644
--- a/Spear/Render/AnimatedModel.hs
+++ b/Spear/Render/AnimatedModel.hs
@@ -150,8 +150,8 @@ animatedModelResource
150 150
151 rkey <- register $ do 151 rkey <- register $ do
152 putStrLn "Releasing animated model resource" 152 putStrLn "Releasing animated model resource"
153 clean vao 153 release' vao
154 clean elementBuf 154 release' elementBuf
155 155
156 return $ 156 return $
157 AnimatedModelResource 157 AnimatedModelResource
diff --git a/Spear/Render/Core.hs b/Spear/Render/Core.hs
new file mode 100644
index 0000000..b5308ce
--- /dev/null
+++ b/Spear/Render/Core.hs
@@ -0,0 +1,17 @@
1module Spear.Render.Core
2(
3 module Spear.Render.Core.Buffer
4, module Spear.Render.Core.Constants
5, module Spear.Render.Core.Geometry
6, module Spear.Render.Core.Pipeline
7, module Spear.Render.Core.Shader
8, module Spear.Render.Core.State
9)
10where
11
12import Spear.Render.Core.Buffer
13import Spear.Render.Core.Constants
14import Spear.Render.Core.Geometry
15import Spear.Render.Core.Pipeline
16import Spear.Render.Core.Shader
17import Spear.Render.Core.State
diff --git a/Spear/Render/Core/Buffer.hs b/Spear/Render/Core/Buffer.hs
new file mode 100644
index 0000000..6f1e355
--- /dev/null
+++ b/Spear/Render/Core/Buffer.hs
@@ -0,0 +1,122 @@
1module Spear.Render.Core.Buffer
2(
3 BufferData(..)
4, BufferDesc(..)
5, makeBufferAndView
6, makeBuffer
7, deleteBuffer
8, updateBuffer
9)
10where
11
12import Spear.Game
13import Spear.Math.Vector
14import Spear.Render.Core.State
15
16import Control.Monad (void)
17import Data.HashMap as HashMap
18import Data.Word
19import Foreign.C.Types
20import Foreign.Marshal.Alloc
21import Foreign.Marshal.Array
22import Foreign.Ptr
23import Foreign.Storable
24import Graphics.GL.Core46
25import Unsafe.Coerce
26
27
28data BufferData
29 = BufferDataUntyped (Ptr Word8) GLuint
30 | BufferDataVec2 [Vector2]
31 | BufferDataVec3 [Vector3]
32 | BufferDataFloat [Float]
33 | BufferDataU8 [Word8]
34 | BufferDataU16 [Word16]
35 | BufferUninitialized
36
37data BufferDesc = BufferDesc
38 { bufferDescUsage :: BufferUsage
39 , bufferDescType :: BufferType
40 , bufferDescData :: BufferData
41 }
42
43
44makeBufferAndView :: BufferDesc -> Game RenderCoreState (BufferView a)
45makeBufferAndView desc = do
46 buffer <- makeBuffer desc
47 return BufferView
48 { bufferViewBuffer = buffer
49 , bufferViewOffsetBytes = 0
50 , bufferViewSizeBytes = bufferDataSizeBytes $ bufferDescData desc
51 , bufferViewStrideBytes = 0
52 }
53
54makeBuffer :: BufferDesc -> Game RenderCoreState Buffer
55makeBuffer (BufferDesc usage bufferType bufferData) = do
56 handle <- gameIO $ alloca $ \ptr -> glGenBuffers 1 ptr >> peek ptr
57 resourceKey <- register $ deleteBuffer' handle
58 let buffer = Buffer handle resourceKey bufferType usage
59 gameIO $ updateBuffer buffer bufferData
60 modifyGameState (\state -> state {
61 buffers = HashMap.insert handle buffer (buffers state) })
62 return buffer
63
64deleteBuffer :: Buffer -> Game RenderCoreState ()
65deleteBuffer buffer = do
66 let matches buffer = (==bufferHandle buffer) . bufferHandle
67 modifyGameState (\state -> state {
68 buffers = HashMap.delete (bufferHandle buffer) (buffers state) })
69 release buffer
70
71-- TODO: use glBufferSubData for updates.
72updateBuffer :: Buffer -> BufferData -> IO ()
73updateBuffer buffer bufferData =
74 case bufferData of
75 BufferUninitialized -> return ()
76 _ -> do
77 glBindBuffer GL_ARRAY_BUFFER (bufferHandle buffer)
78 uploadData (bufferUsage buffer) bufferData
79 glBindBuffer GL_ARRAY_BUFFER 0
80
81-- Private
82
83deleteBuffer' :: GLuint -> IO ()
84deleteBuffer' handle = alloca $ \ptr -> do
85 poke ptr handle
86 glDeleteBuffers 1 ptr
87
88uploadData :: BufferUsage -> BufferData -> IO ()
89uploadData usage bufferData = case bufferData of
90 BufferDataUntyped ptr sizeBytes -> do
91 glBufferData GL_ARRAY_BUFFER (fromIntegral sizeBytes) (unsafeCoerce ptr) usage'
92 BufferDataVec2 vec2s -> withArrayLen vec2s $ \numElems ptr -> do
93 let sizeBytes = numElems * sizeOf (undefined :: Vector2)
94 glBufferData GL_ARRAY_BUFFER (fromIntegral sizeBytes) ptr usage'
95 BufferDataVec3 vec3s -> withArrayLen vec3s $ \numElems ptr -> do
96 let sizeBytes = numElems * sizeOf (undefined :: Vector3)
97 glBufferData GL_ARRAY_BUFFER (fromIntegral sizeBytes) ptr usage'
98 BufferDataFloat floats -> withArrayLen floats $ \numElems ptr -> do
99 let sizeBytes = numElems * sizeOf (undefined :: CFloat)
100 glBufferData GL_ARRAY_BUFFER (fromIntegral sizeBytes) ptr usage'
101 BufferDataU8 ints -> withArrayLen ints $ \numElems ptr -> do
102 let sizeBytes = numElems * sizeOf (undefined :: Word8)
103 glBufferData GL_ARRAY_BUFFER (fromIntegral sizeBytes) ptr usage'
104 BufferDataU16 ints -> withArrayLen ints $ \numElems ptr -> do
105 let sizeBytes = numElems * sizeOf (undefined :: Word16)
106 glBufferData GL_ARRAY_BUFFER (fromIntegral sizeBytes) ptr usage'
107 BufferUninitialized ->
108 return ()
109 where usage' = toGLUsage usage
110
111toGLUsage :: BufferUsage -> GLenum
112toGLUsage BufferStatic = GL_STATIC_DRAW
113toGLUsage BufferDynamic = GL_DYNAMIC_DRAW
114
115bufferDataSizeBytes :: BufferData -> GLuint
116bufferDataSizeBytes bufferData = case bufferData of
117 BufferDataUntyped ptr sizeBytes -> sizeBytes
118 BufferDataVec2 vec2s -> fromIntegral $ length vec2s * sizeOf (undefined :: Vector2)
119 BufferDataVec3 vec3s -> fromIntegral $ length vec3s * sizeOf (undefined :: Vector3)
120 BufferDataFloat floats -> fromIntegral $ length floats * 4
121 BufferDataU8 bytes -> fromIntegral $ length bytes
122 BufferDataU16 words -> fromIntegral $ length words * 2
diff --git a/Spear/Render/Core/Constants.hs b/Spear/Render/Core/Constants.hs
new file mode 100644
index 0000000..befd8ed
--- /dev/null
+++ b/Spear/Render/Core/Constants.hs
@@ -0,0 +1,12 @@
1module Spear.Render.Core.Constants where
2
3
4import Graphics.GL.Core46
5
6
7positionChannel = 0 :: GLuint
8normalChannel = 1 :: GLuint
9tangentChannel = 2 :: GLuint
10texcoordsChannel = 3 :: GLuint
11jointsChannel = 4 :: GLuint
12weightsChannel = 5 :: GLuint
diff --git a/Spear/Render/Core/Geometry.hs b/Spear/Render/Core/Geometry.hs
new file mode 100644
index 0000000..aa0dfe5
--- /dev/null
+++ b/Spear/Render/Core/Geometry.hs
@@ -0,0 +1,150 @@
1module Spear.Render.Core.Geometry
2(
3 newGeometryDesc
4, makeGeometry
5, deleteGeometry
6, renderGeometry
7, setPositions
8)
9where
10
11
12import Spear.Game
13import Spear.Math.Vector.Vector3
14import Spear.Render.Core.Buffer
15import Spear.Render.Core.Constants
16import Spear.Render.Core.State
17
18import Data.HashMap as HashMap
19import Data.IORef
20import Foreign.Marshal.Alloc
21import Foreign.Storable
22import Graphics.GL.Core46
23import Unsafe.Coerce
24
25
26newGeometryDesc :: GeometryDesc
27newGeometryDesc = GeometryDesc
28 { positions = Nothing
29 , normals = Nothing
30 , tangents = Nothing
31 , texcoords = Nothing
32 , joints = Nothing
33 , weights = Nothing
34 , indices = Nothing
35 , numVerts = 0
36 , numIndices = 0
37 , primitiveType = Triangles
38 }
39
40
41makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry
42makeGeometry desc = do
43 handle <- gameIO $ alloca $ \ptr -> glGenVertexArrays 1 ptr >> peek ptr
44 gameIO $ do
45 glBindVertexArray handle
46 configureVertexAttributes desc
47 glBindVertexArray 0
48 descRef <- gameIO $ newIORef desc
49 resourceKey <- register $ deleteGeometry' handle
50 let geometry = Geometry handle resourceKey descRef
51 modifyGameState (\state -> state {
52 geometries = HashMap.insert handle geometry (geometries state) })
53 return geometry
54
55deleteGeometry :: Geometry -> Game RenderCoreState ()
56deleteGeometry geometry = do
57 modifyGameState (\state -> state {
58 geometries = HashMap.delete (geometryVao geometry) (geometries state) })
59 release geometry
60
61renderGeometry :: Geometry -> IO ()
62renderGeometry geometry = do
63 desc <- readIORef (geometryDesc geometry)
64 let mode = toGLPrimitiveType $ primitiveType desc
65 glBindVertexArray (geometryVao geometry)
66 case indices desc of
67 (Just (IndicesU8 view)) -> renderIndexed view mode (numIndices desc) GL_UNSIGNED_BYTE
68 (Just (IndicesU16 view)) -> renderIndexed view mode (numIndices desc) GL_UNSIGNED_SHORT
69 Nothing -> glDrawArrays mode 0 (numVerts desc)
70 glBindVertexArray 0
71
72-- Functions for updating dynamic geometry.
73
74setPositions :: Geometry -> [Vector3] -> IO ()
75setPositions geometry vectors = do
76 desc <- readIORef $ geometryDesc geometry
77 case positions desc of
78 Just (Positions3d view) -> do
79 updateBuffer (bufferViewBuffer view) (BufferDataVec3 vectors)
80 updateGeometry geometry $ \desc -> desc {
81 numVerts = fromIntegral . length $ vectors
82 }
83 _ -> putStrLn "setPositions ERROR" -- TODO: handle gracefully
84
85-- Private
86
87deleteGeometry' :: GLenum -> IO ()
88deleteGeometry' handle = alloca $ \ptr -> do
89 poke ptr handle
90 glDeleteVertexArrays 1 ptr
91
92updateGeometry :: Geometry -> (GeometryDesc -> GeometryDesc) -> IO ()
93updateGeometry geometry update = do
94 desc <- readIORef $ geometryDesc geometry
95 writeIORef (geometryDesc geometry) (update desc)
96
97renderIndexed :: BufferView a -> GLenum -> GLsizei -> GLenum -> IO ()
98renderIndexed view mode numIndices indexElemSize = do
99 glBindBuffer GL_ELEMENT_ARRAY_BUFFER (bufferHandle . bufferViewBuffer $ view)
100 glDrawElements mode numIndices GL_UNSIGNED_SHORT (unsafeCoerce $ bufferViewOffsetBytes view)
101 glBindBuffer GL_ELEMENT_ARRAY_BUFFER 0
102
103configureVertexAttributes :: GeometryDesc -> IO ()
104configureVertexAttributes desc = do
105 case positions desc of
106 Just (Positions2d view) -> configureView view positionChannel 2 GL_FLOAT GL_FALSE
107 Just (Positions3d view) -> configureView view positionChannel 3 GL_FLOAT GL_FALSE
108 Nothing -> return ()
109 case normals desc of
110 Just view -> configureView view normalChannel 3 GL_FLOAT GL_FALSE
111 Nothing -> return ()
112 case tangents desc of
113 Just view -> configureView view tangentChannel 4 GL_FLOAT GL_FALSE
114 Nothing -> return ()
115 case texcoords desc of
116 Just view -> configureView view texcoordsChannel 2 GL_FLOAT GL_FALSE
117 Nothing -> return ()
118 case joints desc of
119 Just (JointsU8 view) -> configureView view jointsChannel 4 GL_UNSIGNED_BYTE GL_FALSE
120 Just (JointsU16 view) -> configureView view jointsChannel 4 GL_UNSIGNED_SHORT GL_FALSE
121 Nothing -> return ()
122 case weights desc of
123 Just (WeightsU8 view) -> configureView view weightsChannel 4 GL_UNSIGNED_BYTE GL_TRUE
124 Just (WeightsU16 view) -> configureView view weightsChannel 4 GL_UNSIGNED_SHORT GL_TRUE
125 Just (WeightsFloat view) -> configureView view weightsChannel 4 GL_FLOAT GL_FALSE
126 Nothing -> return ()
127
128-- TODO: Add the assertion:
129-- desc->num_verts <= view->size_bytes / (num_components * component_size_bytes
130configureView :: BufferView a -> GLuint -> GLint -> GLenum -> GLboolean -> IO ()
131configureView view channel numComponents componentType normalized = do
132 glBindBuffer GL_ARRAY_BUFFER (bufferHandle . bufferViewBuffer $ view)
133 glEnableVertexAttribArray channel
134 let strideBytes = bufferViewStrideBytes view
135 let offsetBytes = unsafeCoerce $ bufferViewOffsetBytes view
136 if (componentType == GL_FLOAT) || (normalized == GL_TRUE)
137 then do
138 glVertexAttribPointer channel numComponents componentType normalized
139 strideBytes offsetBytes
140 else
141 -- TODO: Assert component type
142 glVertexAttribIPointer channel numComponents componentType
143 strideBytes offsetBytes
144 glBindBuffer GL_ARRAY_BUFFER 0
145
146toGLPrimitiveType :: PrimitiveType -> GLenum
147toGLPrimitiveType primitiveType = case primitiveType of
148 Triangles -> GL_TRIANGLES
149 TriangleFan -> GL_TRIANGLE_FAN
150 TriangleStrip -> GL_TRIANGLE_STRIP
diff --git a/Spear/Render/Core/Pipeline.hs b/Spear/Render/Core/Pipeline.hs
new file mode 100644
index 0000000..724b391
--- /dev/null
+++ b/Spear/Render/Core/Pipeline.hs
@@ -0,0 +1,74 @@
1module Spear.Render.Core.Pipeline
2(
3 BufferTarget(..)
4, clearBuffers
5, setBlending
6, setClearColour
7, setClearDepth
8, setClearStencil
9, setCulling
10, setDepthMask
11, setPolygonOffset
12, setViewport
13)
14where
15
16import Data.Bits ((.|.))
17import Data.List (foldl')
18import Graphics.GL.Core46
19
20
21data BufferTarget
22 = ColourBuffer
23 | DepthBuffer
24 | StencilBuffer
25
26
27clearBuffers :: [BufferTarget] -> IO ()
28clearBuffers = glClear . toBufferBitfield
29 where toBufferBitfield = foldl' (.|.) 0 . (<$>) toGLEnum
30 toGLEnum target = case target of
31 ColourBuffer -> GL_COLOR_BUFFER_BIT
32 DepthBuffer -> GL_DEPTH_BUFFER_BIT
33 StencilBuffer -> GL_STENCIL_BUFFER_BIT
34
35setBlending :: Bool -> IO ()
36setBlending enable =
37 if enable
38 then glEnable GL_BLEND >> glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
39 else glDisable GL_BLEND
40
41setClearColour :: (Float, Float, Float, Float) -> IO ()
42setClearColour (r,g,b,a) = glClearColor r g b a
43
44setClearDepth :: Double -> IO ()
45setClearDepth = glClearDepth
46
47setClearStencil :: Int -> IO ()
48setClearStencil = glClearStencil . fromIntegral
49
50setCulling :: Bool -> IO ()
51setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE
52
53setDepthMask :: Bool -> IO ()
54setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE)
55
56setPolygonOffset :: Float -> Float -> IO ()
57setPolygonOffset scale bias = do
58 glPolygonOffset scale bias
59 if scale /= 0 && bias /= 0
60 then glEnable GL_POLYGON_OFFSET_FILL
61 else glDisable GL_POLYGON_OFFSET_FILL
62
63setViewport ::
64 -- | x
65 Int ->
66 -- | y
67 Int ->
68 -- | width
69 Int ->
70 -- | height
71 Int ->
72 IO ()
73setViewport x y width height =
74 glViewport (fromIntegral x) (fromIntegral y) (fromIntegral width) (fromIntegral height)
diff --git a/Spear/Render/Core/Shader.hs b/Spear/Render/Core/Shader.hs
new file mode 100644
index 0000000..4ed4430
--- /dev/null
+++ b/Spear/Render/Core/Shader.hs
@@ -0,0 +1,216 @@
1module Spear.Render.Core.Shader
2(
3 Define(..)
4, ShaderSource(..)
5, ShaderDesc(..)
6, compileShader
7, compileShaderProgram
8, deleteShader
9, deleteShaderProgram
10, activateShaderProgram
11, deactivateShaderProgram
12, setUniform
13, applyUniforms
14)
15where
16
17import Spear.Game
18import Spear.Math.Matrix4
19import Spear.Math.Vector
20import Spear.Render.Core.State
21
22import Control.Monad (mapM_)
23import Data.Bits
24import Data.Hashable
25import Data.HashMap as HashMap
26import Data.IORef
27import Data.List (deleteBy, foldl', intercalate)
28import Foreign.C.String
29import Foreign.Marshal.Alloc
30import Foreign.Marshal.Array
31import Foreign.Marshal.Utils
32import Foreign.Ptr
33import Foreign.Storable
34import Graphics.GL.Core46
35import Unsafe.Coerce
36
37
38type Define = (String, String)
39
40data ShaderSource
41 = ShaderFromString String
42 | ShaderFromFile FilePath
43 deriving Show
44
45data ShaderDesc = ShaderDesc
46 { shaderDescType :: ShaderType
47 , shaderDescSource :: ShaderSource
48 , shaderDescDefines :: [Define]
49 }
50
51
52compileShader :: ShaderDesc -> Game RenderCoreState Shader
53compileShader (ShaderDesc shaderType source defines) = do
54 code <- case source of
55 ShaderFromString code -> return code
56 ShaderFromFile file -> gameIO $ readFile file
57 state <- getGameState
58 let shaderHash = hash code -- TODO: Should also include defines.
59 case HashMap.lookup shaderHash (shaders state) of
60 Just shader -> return shader
61 Nothing -> do
62 let definesString = makeDefinesString defines
63 handle <- gameIO $ glCreateShader (toGLShaderType shaderType)
64 gameIO $ withCStringLen code $ \(codeCString, codeLen) ->
65 withCStringLen definesString $ \(definesCString, definesLen) ->
66 withCStringLen header $ \(headerCString, headerLen) ->
67 withArray [headerCString, definesCString, codeCString] $ \strPtrs ->
68 withArray (fromIntegral <$> [headerLen, definesLen, codeLen] :: [GLint])
69 $ \lengths ->
70 glShaderSource handle 3 strPtrs lengths
71 err <- gameIO $ do
72 glCompileShader handle
73 alloca $ \statusPtr -> do
74 glGetShaderiv handle GL_COMPILE_STATUS statusPtr
75 result <- peek statusPtr
76 case result of
77 0 -> alloca $ \lenPtr -> do
78 glGetShaderiv handle GL_INFO_LOG_LENGTH lenPtr
79 len <- peek lenPtr
80 case len of
81 0 -> return $ Just ""
82 _ -> withCString (replicate (fromIntegral len) '\0') $ \logPtr -> do
83 glGetShaderInfoLog handle len nullPtr logPtr
84 Just <$> peekCString logPtr
85 _ -> return Nothing
86 case err of
87 Nothing -> do
88 resourceKey <- register $ deleteShader' handle
89 let shader = Shader handle resourceKey shaderType shaderHash
90 saveGameState $ state {
91 shaders = HashMap.insert shaderHash shader (shaders state)
92 }
93 return shader
94 Just err -> gameError $
95 "Failed to compile shader: [" ++ show source ++ "]: " ++ err
96
97compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram
98compileShaderProgram shaders = do
99 state <- getGameState
100 let programHash = hashShaders shaders
101 case HashMap.lookup programHash (shaderPrograms state) of
102 Just program -> return program
103 Nothing -> do
104 handle <- gameIO glCreateProgram
105 case handle of
106 0 -> gameError "Failed to create shader program"
107 _ -> do
108 mapM_ (gameIO . glAttachShader handle) (shaderHandle <$> shaders)
109 err <- gameIO $ do
110 glLinkProgram handle
111 alloca $ \statusPtr -> do
112 glGetProgramiv handle GL_LINK_STATUS statusPtr
113 status <- peek statusPtr
114 case status of
115 0 -> alloca $ \lenPtr -> do
116 glGetShaderiv handle GL_INFO_LOG_LENGTH lenPtr
117 len <- peek lenPtr
118 case len of
119 0 -> return $ Just "Unknown error"
120 _ -> withCString (replicate (fromIntegral len) '\0') $ \logPtr -> do
121 glGetShaderInfoLog handle len nullPtr logPtr
122 Just <$> peekCString logPtr
123 _ -> return Nothing
124 case err of
125 Nothing -> do
126 resourceKey <- register $ deleteShaderProgram' handle
127 uniforms <- gameIO $ newIORef []
128 let program = ShaderProgram handle resourceKey programHash uniforms
129 saveGameState $ state {
130 shaderPrograms = HashMap.insert programHash program (shaderPrograms state)
131 }
132 return program
133 Just err -> gameError $
134 "Failed to compile shader program: " ++ err ++ "; shaders: " ++
135 intercalate ", " (show . shaderHandle <$> shaders)
136
137deleteShader :: Shader -> Game RenderCoreState ()
138deleteShader shader = do
139 modifyGameState (\state -> state {
140 shaders = HashMap.delete (shaderHash shader) (shaders state) })
141 release shader
142
143deleteShaderProgram :: ShaderProgram -> Game RenderCoreState ()
144deleteShaderProgram program = do
145 modifyGameState (\state -> state {
146 shaderPrograms = HashMap.delete (shaderProgramHash program) (shaderPrograms state)})
147 release program
148
149activateShaderProgram :: ShaderProgram -> IO ()
150activateShaderProgram program = do
151 glUseProgram . shaderProgramHandle $ program
152 applyUniforms program
153
154deactivateShaderProgram :: ShaderProgram -> IO ()
155deactivateShaderProgram _ = glUseProgram 0
156
157setUniform :: ShaderUniform -> ShaderProgram -> IO ()
158setUniform uniform program =
159 modifyIORef (shaderProgramUniforms program) (setUniform' . removeUniform)
160 where removeUniform = deleteBy matchesUniform uniform
161 matchesUniform uniform u = uniformName u == uniformName uniform
162 setUniform' = (:) uniform
163
164applyUniforms :: ShaderProgram -> IO ()
165applyUniforms program =
166 let update (FloatUniform name value) =
167 glGetUniformLocation' handle name >>=
168 \location -> glUniform1f (fromIntegral location) value
169 update (Vec3Uniform name (Vector3 x y z)) =
170 glGetUniformLocation' handle name >>=
171 \location -> glUniform3f (fromIntegral location) x y z
172 update (Vec4Uniform name (Vector4 x y z w)) =
173 glGetUniformLocation' handle name >>=
174 \location -> glUniform4f (fromIntegral location) x y z w
175 update (Mat4Uniform name mat4) =
176 glGetUniformLocation' handle name >>=
177 \location -> with mat4 $ \ptrMat4 ->
178 glUniformMatrix4fv location 1 GL_FALSE (unsafeCoerce ptrMat4)
179 update (Mat4ArrayUniform name mat4s) =
180 glGetUniformLocation' handle name >>=
181 \location -> withArray mat4s $ \ptrMat4s ->
182 glUniformMatrix4fv location (fromIntegral $ length mat4s) GL_FALSE (unsafeCoerce ptrMat4s)
183 handle = shaderProgramHandle program
184 in do
185 uniforms <- readIORef (shaderProgramUniforms program)
186 mapM_ update uniforms
187 writeIORef (shaderProgramUniforms program) []
188
189-- Private
190
191glGetUniformLocation' :: GLuint -> String -> IO GLint
192glGetUniformLocation' handle name =
193 withCString name $ \nameCStr ->
194 glGetUniformLocation (fromIntegral handle) (unsafeCoerce nameCStr)
195
196deleteShader' :: GLuint -> IO ()
197deleteShader' = glDeleteShader
198
199deleteShaderProgram' :: GLuint -> IO ()
200deleteShaderProgram' = glDeleteProgram
201
202hashShaders :: [Shader] -> Int
203hashShaders = foldl' hashF 0
204 where hashF hash shader = (hash `shiftL` 32) .|. fromIntegral (shaderHandle shader)
205
206toGLShaderType :: ShaderType -> GLenum
207toGLShaderType VertexShader = GL_VERTEX_SHADER
208toGLShaderType FragmentShader = GL_FRAGMENT_SHADER
209toGLShaderType ComputeShader = GL_COMPUTE_SHADER
210
211makeDefinesString :: [Define] -> String
212makeDefinesString defines = intercalate "\n" body ++ "\n"
213 where body = (\(name, value) -> "#define " ++ name ++ " " ++ value) <$> defines
214
215-- Header prepended to all shaders.
216header = "#version 400 core\n"
diff --git a/Spear/Render/Core/State.hs b/Spear/Render/Core/State.hs
new file mode 100644
index 0000000..34b0732
--- /dev/null
+++ b/Spear/Render/Core/State.hs
@@ -0,0 +1,157 @@
1module Spear.Render.Core.State where
2
3import Spear.Game
4import Spear.Math.Matrix4
5import Spear.Math.Vector
6
7import Data.HashMap as HashMap
8import Data.IORef
9import Data.Word
10import Graphics.GL.Core46
11
12
13
14data BufferType
15 = BufferUntyped
16 | Buffer2d
17 | Buffer3d
18 | Buffer4d
19 | BufferFloat
20 | BufferU8
21 | BufferU16
22
23data BufferUsage
24 = BufferStatic
25 | BufferDynamic
26
27-- | A data buffer (e.g., vertex attributes, indices).
28data Buffer = Buffer
29 { bufferHandle :: GLuint
30 , bufferResource :: Resource
31 , bufferType :: BufferType
32 , bufferUsage :: BufferUsage
33 }
34
35-- | A buffer view.
36data BufferView a = BufferView
37 { bufferViewBuffer :: Buffer
38 , bufferViewOffsetBytes :: GLuint
39 , bufferViewSizeBytes :: GLuint
40 , bufferViewStrideBytes :: GLsizei
41 }
42
43
44data Positions
45 = Positions2d (BufferView Vector2)
46 | Positions3d (BufferView Vector3)
47
48data Joints
49 = JointsU8 (BufferView Word8)
50 | JointsU16 (BufferView Word16)
51
52data Weights
53 = WeightsU8 (BufferView Word8)
54 | WeightsU16 (BufferView Word16)
55 | WeightsFloat (BufferView Float)
56
57data Indices
58 = IndicesU8 (BufferView Word8)
59 | IndicesU16 (BufferView Word16)
60
61data PrimitiveType
62 = Triangles
63 | TriangleFan
64 | TriangleStrip
65
66-- | A geometry descriptor.
67data GeometryDesc = GeometryDesc
68 { positions :: Maybe Positions -- Convenient for the empty descriptor.
69 , normals :: Maybe (BufferView Vector3)
70 , tangents :: Maybe (BufferView Vector4)
71 , texcoords :: Maybe (BufferView Vector4)
72 , joints :: Maybe Joints
73 , weights :: Maybe Weights
74 , indices :: Maybe Indices
75 , numVerts :: GLsizei
76 , numIndices :: GLsizei
77 , primitiveType :: PrimitiveType
78 }
79
80-- | A piece of renderable geometry.
81--
82-- Since dynamic geometry can be mutated, the descriptor is stored as an IORef
83-- so that its state cannot become stale after an update.
84data Geometry = Geometry
85 { geometryVao :: GLuint
86 , geometryResource :: Resource
87 , geometryDesc :: IORef GeometryDesc
88 }
89
90
91-- | A shader.
92data Shader = Shader
93 { shaderHandle :: GLuint
94 , shaderResource :: Resource
95 , shaderType :: ShaderType
96 , shaderHash :: Int
97 }
98
99data ShaderType
100 = VertexShader
101 | FragmentShader
102 | ComputeShader
103 deriving (Eq, Show)
104
105-- | A shader uniform.
106data ShaderUniform
107 = FloatUniform { uniformName :: String, uniformFloat :: Float }
108 | Vec3Uniform { uniformName :: String, uniformVec3 :: Vector3 }
109 | Vec4Uniform { uniformName :: String, uniformVec4 :: Vector4 }
110 | Mat4Uniform { uniformName :: String, uniformMat4 :: Matrix4 }
111 | Mat4ArrayUniform { uniformName :: String, uniformMat4s :: [Matrix4] }
112
113-- | A shader program.
114data ShaderProgram = ShaderProgram
115 { shaderProgramHandle :: GLuint
116 , shaderProgramResource :: Resource
117 , shaderProgramHash :: Int
118 -- Dirty set of uniforms that have been set since the last time uniforms were
119 -- applied. OpenGL retains the values of uniforms for a program until the
120 -- program is linked again, so we only need to store the updates here.
121 , shaderProgramUniforms :: IORef [ShaderUniform]
122 }
123
124
125-- | Core render state.
126data RenderCoreState = RenderCoreState
127 { buffers :: Map GLuint Buffer
128 , geometries :: Map GLuint Geometry
129 , shaders :: Map ShaderHash Shader
130 , shaderPrograms :: Map ShaderProgramHash ShaderProgram
131 }
132
133type ShaderHash = Int
134type ShaderProgramHash = Int
135
136
137
138instance ResourceClass Buffer where
139 getResource = bufferResource
140
141instance ResourceClass Geometry where
142 getResource = geometryResource
143
144instance ResourceClass Shader where
145 getResource = shaderResource
146
147instance ResourceClass ShaderProgram where
148 getResource = shaderProgramResource
149
150
151newRenderCoreState :: RenderCoreState
152newRenderCoreState = RenderCoreState
153 { buffers = HashMap.empty
154 , geometries = HashMap.empty
155 , shaders = HashMap.empty
156 , shaderPrograms = HashMap.empty
157 }
diff --git a/Spear/Render/Immediate.hs b/Spear/Render/Immediate.hs
new file mode 100644
index 0000000..ca5d5c5
--- /dev/null
+++ b/Spear/Render/Immediate.hs
@@ -0,0 +1,166 @@
1{-# LANGUAGE NoImplicitPrelude #-}
2
3module Spear.Render.Immediate
4(
5 ImmRenderState
6, newImmRenderer
7, deleteImmRenderer
8, immStart
9, immEnd
10, immDrawTriangles
11, immDrawQuads
12, immDrawTriangles2d
13, immDrawQuads2d
14, immLoadIdentity
15, immTranslate
16, immPushMatrix
17, immPopMatrix
18, immPreservingMatrix
19, immSetColour
20, immSetModelMatrix
21, immSetViewProjectionMatrix
22)
23where
24
25
26import Spear.Game
27import Spear.Math.Algebra
28import Spear.Math.Matrix4 as Matrix4
29import Spear.Math.Vector
30import Spear.Prelude
31import Spear.Render.Core.Buffer
32import Spear.Render.Core.Geometry
33import Spear.Render.Core.Shader
34import Spear.Render.Core.State hiding (shaders)
35
36import Control.Monad (unless)
37import Data.List (foldl')
38
39
40data ImmRenderState = ImmRenderState
41 { shaders :: [Shader]
42 , shader :: ShaderProgram
43 , triangles :: Geometry
44 , matrixStack :: [Matrix4] -- Pre-multiplied matrices. Never empty.
45 }
46
47
48newImmRenderer :: Game RenderCoreState ImmRenderState
49newImmRenderer = do
50 -- TODO: Move shaders to Spear project.
51 vs <- compileShader $ ShaderDesc VertexShader
52 (ShaderFromFile "/home/jeanne/src/gfx/gfx/shaders/immediate_mode.vert") []
53 ps <- compileShader $ ShaderDesc FragmentShader
54 (ShaderFromFile "/home/jeanne/src/gfx/gfx/shaders/immediate_mode.frag") []
55 shader <- compileShaderProgram [vs, ps]
56
57 -- TODO: Make 'makeGeometry' easier to use. GeometryDesc should be able to
58 -- take (possibly empty) lists as inputs.
59 positions <- makeBufferAndView $
60 BufferDesc BufferDynamic Buffer3d BufferUninitialized
61 triangles <- makeGeometry $ newGeometryDesc
62 { positions = Just (Positions3d positions)
63 , primitiveType = Triangles
64 }
65
66 return ImmRenderState
67 { shaders = [vs, ps]
68 , shader = shader
69 , triangles = triangles
70 , matrixStack = [Matrix4.id]
71 }
72
73deleteImmRenderer :: ImmRenderState -> Game RenderCoreState ()
74deleteImmRenderer immState = do
75 deleteShaderProgram (shader immState)
76 mapM_ deleteShader (shaders immState)
77 deleteGeometry (triangles immState)
78
79-- The functions below are all defined inside the Game ImmRenderState monad so
80-- that all of the drawing can conveniently happen inside the monad.
81
82immStart :: Game ImmRenderState ()
83immStart = do
84 state <- getGameState
85 gameIO $ activateShaderProgram (shader state)
86
87immEnd :: Game ImmRenderState ()
88immEnd = do
89 state <- getGameState
90 gameIO $ deactivateShaderProgram (shader state)
91
92immDrawTriangles :: [Vector3] -> Game ImmRenderState ()
93immDrawTriangles vertices = do
94 unless (null vertices) $ do
95 loadMatrixStack
96 state <- getGameState
97 gameIO $ do
98 setPositions (triangles state) vertices
99 applyUniforms (shader state)
100 renderGeometry (triangles state)
101
102-- TODO: use triangle strips for quads. Will need a separate Geometry.
103immDrawQuads :: [(Vector3, Vector3, Vector3, Vector3)] -> Game ImmRenderState ()
104immDrawQuads quads = immDrawTriangles triangles
105 where
106 triangles = concatMap toTriangles quads
107 toTriangles (p0, p1, p2, p3) = [p0, p1, p2, p0, p2, p3]
108
109immDrawTriangles2d :: [Vector2] -> Game ImmRenderState ()
110immDrawTriangles2d = immDrawTriangles . (<$>) to3d
111
112immDrawQuads2d :: [(Vector2, Vector2, Vector2, Vector2)] -> Game ImmRenderState ()
113immDrawQuads2d =
114 immDrawQuads . (<$>) (\(p0, p1, p2, p3) -> (to3d p0, to3d p1, to3d p2, to3d p3))
115
116immLoadIdentity :: Game ImmRenderState ()
117immLoadIdentity = modifyGameState $ \state -> state {
118 matrixStack = [Matrix4.id] }
119
120immTranslate :: Vector3 -> Game ImmRenderState ()
121immTranslate vector = modifyGameState $ pushMatrix (Matrix4.translatev vector)
122
123immPushMatrix :: Matrix4 -> Game ImmRenderState ()
124immPushMatrix matrix = modifyGameState $ pushMatrix matrix
125
126immPopMatrix :: Game ImmRenderState ()
127immPopMatrix = modifyGameState $ \state -> state {
128 matrixStack = case matrixStack state of
129 [x] -> [x] -- Always keep the identity matrix on the stack.
130 x:xs -> xs }
131
132immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a
133immPreservingMatrix f = do
134 originalStack <- matrixStack <$> getGameState
135 result <- f
136 modifyGameState $ \state -> state { matrixStack = originalStack }
137 return result
138
139immSetColour :: Vector4 -> Game ImmRenderState ()
140immSetColour colour = do
141 state <- getGameState
142 gameIO $ setUniform (Vec4Uniform "Colour" colour) (shader state)
143
144immSetModelMatrix :: Matrix4 -> Game ImmRenderState ()
145immSetModelMatrix model = do
146 state <- getGameState
147 gameIO $ setUniform (Mat4Uniform "Model" model) (shader state)
148
149immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState ()
150immSetViewProjectionMatrix viewProjection = do
151 state <- getGameState
152 gameIO $ setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state)
153
154-- Private
155
156pushMatrix :: Matrix4 -> ImmRenderState -> ImmRenderState
157pushMatrix matrix state = state {
158 matrixStack = matrix * head (matrixStack state) : matrixStack state }
159
160loadMatrixStack :: Game ImmRenderState ()
161loadMatrixStack = do
162 state <- getGameState
163 immSetModelMatrix (head $ matrixStack state)
164
165to3d :: Vector2 -> Vector3
166to3d (Vector2 x y) = vec3 x y 0
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs
index 327e8b0..f4cddf8 100644
--- a/Spear/Render/StaticModel.hs
+++ b/Spear/Render/StaticModel.hs
@@ -99,8 +99,8 @@ staticModelResource (StaticProgramChannels vertChan normChan texChan) material t
99 99
100 rkey <- register $ do 100 rkey <- register $ do
101 putStrLn "Releasing static model resource" 101 putStrLn "Releasing static model resource"
102 clean vao 102 release' vao
103 clean elementBuf 103 release' elementBuf
104 104
105 return $ 105 return $
106 StaticModelResource 106 StaticModelResource
diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs
index 668a495..3cd89f3 100644
--- a/Spear/Scene/Loader.hs
+++ b/Spear/Scene/Loader.hs
@@ -185,12 +185,12 @@ loadModel' file rotation scale = do
185rotateModel :: Rotation -> Model -> Model 185rotateModel :: Rotation -> Model -> Model
186rotateModel (Rotation ax ay az order) model = 186rotateModel (Rotation ax ay az order) model =
187 let mat = case order of 187 let mat = case order of
188 XYZ -> rotZ az * rotY ay * rotX ax 188 XYZ -> rotateZ az * rotateY ay * rotateX ax
189 XZY -> rotY ay * rotZ az * rotX ax 189 XZY -> rotateY ay * rotateZ az * rotateX ax
190 YXZ -> rotZ az * rotX ax * rotY ay 190 YXZ -> rotateZ az * rotateX ax * rotateY ay
191 YZX -> rotX ax * rotZ az * rotY ay 191 YZX -> rotateX ax * rotateZ az * rotateY ay
192 ZXY -> rotY ay * rotX ax * rotZ az 192 ZXY -> rotateY ay * rotateX ax * rotateZ az
193 ZYX -> rotX ax * rotY ay * rotZ az 193 ZYX -> rotateX ax * rotateY ay * rotateZ az
194 normalMat = fastNormalMatrix mat 194 normalMat = fastNormalMatrix mat
195 195
196 vTransform (Vec3 x' y' z') = 196 vTransform (Vec3 x' y' z') =
diff --git a/Spear/Window.hs b/Spear/Window.hs
index cbb9121..3cdc5f5 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -1,7 +1,6 @@
1module Spear.Window 1module Spear.Window
2 ( -- * Setup 2 ( -- * Setup
3 Dimensions, 3 Dimensions,
4 Context,
5 WindowTitle, 4 WindowTitle,
6 5
7 -- * Window 6 -- * Window
@@ -31,13 +30,18 @@ module Spear.Window
31 ) 30 )
32where 31where
33 32
33import Spear.Game
34
34import Control.Concurrent.MVar 35import Control.Concurrent.MVar
35import Control.Exception 36import Control.Exception
36import Control.Monad (foldM, unless, void, when) 37import Control.Monad (foldM, unless, void, when)
37import Data.Functor ((<&>)) 38import Data.Functor ((<&>))
38import Data.Maybe (fromJust, fromMaybe, isJust) 39import Data.Maybe (fromJust, fromMaybe, isJust)
39import qualified Graphics.UI.GLFW as GLFW 40import qualified Graphics.UI.GLFW as GLFW
40import Spear.Game 41
42
43-- OpenGL major and minor versions
44(major, minor) = (4, 4)
41 45
42type Width = Int 46type Width = Int
43 47
@@ -46,14 +50,14 @@ type Height = Int
46-- | Window dimensions. 50-- | Window dimensions.
47type Dimensions = (Width, Height) 51type Dimensions = (Width, Height)
48 52
49-- | A pair specifying the desired OpenGL context, of the form (Major, Minor).
50type Context = (Int, Int)
51
52type WindowTitle = String 53type WindowTitle = String
53 54
54-- | Game initialiser. 55-- | Game initialiser.
55type Init s = Window -> Game () s 56type Init s = Window -> Game () s
56 57
58-- | Game finalizer.
59type End s = Game s ()
60
57-- | Window exception. 61-- | Window exception.
58newtype WindowException = WindowException String deriving (Show) 62newtype WindowException = WindowException String deriving (Show)
59 63
@@ -78,22 +82,23 @@ data Window = Window
78 , windowEventsMVar :: MVar [WindowEvent] 82 , windowEventsMVar :: MVar [WindowEvent]
79 } 83 }
80 84
85
81withWindow :: 86withWindow ::
82 Dimensions -> 87 Dimensions ->
83 Context ->
84 Maybe WindowTitle -> 88 Maybe WindowTitle ->
85 Init s -> 89 Init s ->
90 End s ->
86 (Window -> Game s a) -> 91 (Window -> Game s a) ->
87 IO a 92 IO a
88withWindow dim@(w, h) glVersion windowTitle init run = do 93withWindow dim@(w, h) windowTitle init end run = do
89 flip runGame' () $ do 94 flip evalGame () $ do
90 window <- gameIO $ do 95 window <- gameIO $ do
91 success <- GLFW.init 96 success <- GLFW.init
92 unless success $ throw (WindowException "GLFW.initialize failed") 97 unless success $ throw (WindowException "GLFW.initialize failed")
93 setup dim glVersion windowTitle 98 setup dim windowTitle
94 gameIO $ GLFW.makeContextCurrent (Just . glfwWindow $ window)
95 gameState <- init window 99 gameState <- init window
96 result <- evalSubGame (run window) gameState 100 (result, endGameState) <- runSubGame (run window) gameState
101 runSubGame' end endGameState
97 gameIO $ do 102 gameIO $ do
98 GLFW.destroyWindow $ glfwWindow window 103 GLFW.destroyWindow $ glfwWindow window
99 GLFW.terminate 104 GLFW.terminate
@@ -101,10 +106,9 @@ withWindow dim@(w, h) glVersion windowTitle init run = do
101 106
102setup :: 107setup ::
103 Dimensions -> 108 Dimensions ->
104 Context ->
105 Maybe WindowTitle -> 109 Maybe WindowTitle ->
106 IO Window 110 IO Window
107setup (w, h) (major, minor) windowTitle = do 111setup (w, h) windowTitle = do
108 closeRequest <- newEmptyMVar 112 closeRequest <- newEmptyMVar
109 windowEvents <- newEmptyMVar 113 windowEvents <- newEmptyMVar
110 inputEvents <- newEmptyMVar 114 inputEvents <- newEmptyMVar
@@ -113,12 +117,16 @@ setup (w, h) (major, minor) windowTitle = do
113 maybeWindow <- do 117 maybeWindow <- do
114 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major 118 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major
115 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor 119 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor
116 when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Compat 120 when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
117 GLFW.createWindow w h (fromMaybe "Spear" windowTitle) Nothing Nothing 121 GLFW.createWindow w h (fromMaybe "Spear" windowTitle) Nothing Nothing
118 122
119 unless (isJust maybeWindow) $ throwIO (WindowException "GLFW.openWindow failed") 123 unless (isJust maybeWindow)
124 $ throwIO (WindowException "GLFW.openWindow failed")
125
120 let window = fromJust maybeWindow 126 let window = fromJust maybeWindow
121 127
128 GLFW.makeContextCurrent maybeWindow
129
122 GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest 130 GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest
123 GLFW.setWindowSizeCallback window . Just $ onResize windowEvents 131 GLFW.setWindowSizeCallback window . Just $ onResize windowEvents
124 GLFW.setKeyCallback window . Just $ onKey inputEvents 132 GLFW.setKeyCallback window . Just $ onKey inputEvents
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 00:36:54 +0000