diff options
-rw-r--r-- | Demos/Pong/Main.hs | 110 | ||||
-rw-r--r-- | Spear.cabal | 13 | ||||
-rw-r--r-- | Spear/GL.hs | 13 | ||||
-rw-r--r-- | Spear/Game.hs | 53 | ||||
-rw-r--r-- | Spear/Math/Matrix3.hs | 6 | ||||
-rw-r--r-- | Spear/Math/Matrix4.hs | 30 | ||||
-rw-r--r-- | Spear/Math/Spatial3.hs | 6 | ||||
-rw-r--r-- | Spear/Math/Vector/Vector3.hs | 2 | ||||
-rw-r--r-- | Spear/Render/AnimatedModel.hs | 4 | ||||
-rw-r--r-- | Spear/Render/Core.hs | 17 | ||||
-rw-r--r-- | Spear/Render/Core/Buffer.hs | 122 | ||||
-rw-r--r-- | Spear/Render/Core/Constants.hs | 12 | ||||
-rw-r--r-- | Spear/Render/Core/Geometry.hs | 150 | ||||
-rw-r--r-- | Spear/Render/Core/Pipeline.hs | 74 | ||||
-rw-r--r-- | Spear/Render/Core/Shader.hs | 216 | ||||
-rw-r--r-- | Spear/Render/Core/State.hs | 157 | ||||
-rw-r--r-- | Spear/Render/Immediate.hs | 166 | ||||
-rw-r--r-- | Spear/Render/StaticModel.hs | 4 | ||||
-rw-r--r-- | Spear/Scene/Loader.hs | 12 | ||||
-rw-r--r-- | Spear/Window.hs | 38 |
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 @@ | |||
1 | module Main where | 1 | module Main where |
2 | 2 | ||
3 | import Data.Maybe (mapMaybe) | ||
4 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
5 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
6 | import Graphics.Rendering.OpenGL.GL.VertexSpec (currentColor) | ||
7 | import Pong | 3 | import Pong |
4 | |||
8 | import Spear.App | 5 | import Spear.App |
9 | import Spear.Game | 6 | import Spear.Game |
10 | import Spear.Math.AABB | 7 | import Spear.Math.AABB |
8 | import Spear.Math.Matrix4 as Matrix4 hiding | ||
9 | (position) | ||
11 | import Spear.Math.Spatial | 10 | import Spear.Math.Spatial |
12 | import Spear.Math.Spatial2 | 11 | import Spear.Math.Spatial2 |
13 | import Spear.Math.Vector | 12 | import Spear.Math.Vector |
13 | import Spear.Render.Core.Pipeline | ||
14 | import Spear.Render.Core.State | ||
15 | import Spear.Render.Immediate | ||
14 | import Spear.Window | 16 | import Spear.Window |
15 | 17 | ||
18 | import Data.Maybe (mapMaybe) | ||
19 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
20 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
21 | import Graphics.Rendering.OpenGL.GL.VertexSpec (currentColor) | ||
22 | |||
23 | |||
16 | data GameState = GameState | 24 | data 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 | ||
21 | app = App step render resize | 32 | app = App step render resize |
22 | 33 | ||
23 | main = | 34 | main = |
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 | ||
27 | initGame :: Window -> Game () GameState | 38 | initGame :: Window -> Game () GameState |
28 | initGame window = return $ GameState window newWorld | 39 | initGame window = do |
40 | (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState | ||
41 | return $ GameState window renderCoreState immRenderState Matrix4.id newWorld | ||
42 | |||
43 | endGame :: Game GameState () | ||
44 | endGame = do | ||
45 | game <- getGameState | ||
46 | runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game) | ||
29 | 47 | ||
30 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | 48 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool |
31 | step elapsed dt inputEvents = do | 49 | step 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 | ||
40 | render :: Game GameState () | 58 | render :: Game GameState () |
41 | render = getGameState >>= \gs -> gameIO . render' $ world gs | 59 | render = 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 | ||
43 | render' :: [GameObject] -> IO () | 73 | render' :: [GameObject] -> Game ImmRenderState () |
44 | render' world = do | 74 | render' 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 | ||
56 | renderBackground :: IO () | 81 | renderBackground :: Game ImmRenderState () |
57 | renderBackground = | 82 | renderBackground = |
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 | ||
68 | renderGO :: GameObject -> IO () | 93 | renderGO :: GameObject -> Game ImmRenderState () |
69 | renderGO go = do | 94 | renderGO 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. | |
81 | resize :: WindowEvent -> Game s () | 106 | resize :: WindowEvent -> Game GameState () |
82 | resize (ResizeEvent w h) = | 107 | resize (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 | ||
96 | translateEvents = mapMaybe translateEvents' | 120 | translateEvents = 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 | ) |
88 | where | 88 | where |
89 | 89 | ||
90 | import Spear.Assets.Image | ||
91 | import Spear.Game | ||
92 | import Spear.Math.Algebra | ||
93 | import Spear.Math.Matrix3 (Matrix3) | ||
94 | import Spear.Math.Matrix4 (Matrix4) | ||
95 | import Spear.Math.Vector | ||
96 | |||
90 | import Control.Monad | 97 | import Control.Monad |
91 | import Control.Monad.Trans.Class | 98 | import Control.Monad.Trans.Class |
92 | import Control.Monad.Trans.State as State | 99 | import Control.Monad.Trans.State as State |
@@ -103,12 +110,6 @@ import Foreign.Storable | |||
103 | import Foreign.Storable (peek) | 110 | import Foreign.Storable (peek) |
104 | import Graphics.GL.Core46 | 111 | import Graphics.GL.Core46 |
105 | import Prelude hiding ((*)) | 112 | import Prelude hiding ((*)) |
106 | import Spear.Assets.Image | ||
107 | import Spear.Game | ||
108 | import Spear.Math.Algebra | ||
109 | import Spear.Math.Matrix3 (Matrix3) | ||
110 | import Spear.Math.Matrix4 (Matrix4) | ||
111 | import Spear.Math.Vector | ||
112 | import System.Directory (doesFileExist, getCurrentDirectory, | 113 | import System.Directory (doesFileExist, getCurrentDirectory, |
113 | setCurrentDirectory) | 114 | setCurrentDirectory) |
114 | import System.IO (hPutStrLn, stderr) | 115 | import 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 | ) |
31 | where | 36 | where |
@@ -35,23 +40,19 @@ import Control.Monad.State.Strict | |||
35 | import Control.Monad.Trans.Class (lift) | 40 | import Control.Monad.Trans.Class (lift) |
36 | import qualified Control.Monad.Trans.Resource as R | 41 | import qualified Control.Monad.Trans.Resource as R |
37 | 42 | ||
38 | type Resource = R.ReleaseKey | ||
39 | 43 | ||
40 | type Game s = StateT s (R.ResourceT IO) | 44 | type Resource = R.ReleaseKey |
41 | 45 | ||
42 | class ResourceClass a where | 46 | class ResourceClass a where |
43 | getResource :: a -> Resource | 47 | getResource :: a -> Resource |
44 | 48 | ||
45 | release :: a -> Game s () | 49 | type Game s = StateT s (R.ResourceT IO) |
46 | release = unregister . getResource | ||
47 | |||
48 | clean :: a -> IO () | ||
49 | clean = R.release . getResource | ||
50 | 50 | ||
51 | newtype GameException = GameException String deriving (Show) | 51 | newtype GameException = GameException String deriving (Show) |
52 | 52 | ||
53 | instance Exception GameException | 53 | instance Exception GameException |
54 | 54 | ||
55 | |||
55 | -- | Retrieve the game state. | 56 | -- | Retrieve the game state. |
56 | getGameState :: Game s s | 57 | getGameState :: Game s s |
57 | getGameState = get | 58 | getGameState = get |
@@ -69,8 +70,12 @@ register :: IO () -> Game s Resource | |||
69 | register = lift . R.register | 70 | register = lift . R.register |
70 | 71 | ||
71 | -- | Release the given 'Resource'. | 72 | -- | Release the given 'Resource'. |
72 | unregister :: Resource -> Game s () | 73 | release :: ResourceClass a => a -> Game s () |
73 | unregister = lift . R.release | 74 | release = lift . R.release . getResource |
75 | |||
76 | -- | Release the given 'Resource'. | ||
77 | release' :: ResourceClass a => a -> IO () | ||
78 | release' = R.release . getResource | ||
74 | 79 | ||
75 | -- | Throw an error from the 'Game' monad. | 80 | -- | Throw an error from the 'Game' monad. |
76 | gameError :: String -> Game s a | 81 | gameError :: String -> Game s a |
@@ -97,9 +102,9 @@ catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError' | |||
97 | runGame :: Game s a -> s -> IO (a, s) | 102 | runGame :: Game s a -> s -> IO (a, s) |
98 | runGame game = R.runResourceT . runStateT game | 103 | runGame 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. |
101 | runGame' :: Game s a -> s -> IO a | 106 | evalGame :: Game s a -> s -> IO a |
102 | runGame' g s = fst <$> runGame g s | 107 | evalGame 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. |
105 | runSubGame :: Game s a -> s -> Game t (a, s) | 110 | runSubGame :: Game s a -> s -> Game t (a, s) |
@@ -109,14 +114,30 @@ runSubGame g s = gameIO $ runGame g s | |||
109 | runSubGame' :: Game s a -> s -> Game t () | 114 | runSubGame' :: Game s a -> s -> Game t () |
110 | runSubGame' g s = void $ runSubGame g s | 115 | runSubGame' 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. |
113 | evalSubGame :: Game s a -> s -> Game t a | 118 | evalSubGame :: Game s a -> s -> Game t a |
114 | evalSubGame g s = fst <$> runSubGame g s | 119 | evalSubGame 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. |
117 | execSubGame :: Game s a -> s -> Game t s | 122 | execSubGame :: Game s a -> s -> Game t s |
118 | execSubGame g s = snd <$> runSubGame g s | 123 | execSubGame g s = snd <$> runSubGame g s |
119 | 124 | ||
125 | -- | Run the given sibling game, unrolling StateT but not ResourceT. | ||
126 | runSiblingGame :: Game s a -> s -> Game t (a, s) | ||
127 | runSiblingGame g s = lift $ runStateT g s | ||
128 | |||
129 | -- | Like 'runSiblingGame', but discarding the result. | ||
130 | runSiblingGame' :: Game s a -> s -> Game t () | ||
131 | runSiblingGame' g s = void $ runSiblingGame g s | ||
132 | |||
133 | -- | Run the given sibling game and return its result. | ||
134 | evalSiblingGame :: Game s a -> s -> Game t a | ||
135 | evalSiblingGame g s = fst <$> runSiblingGame g s | ||
136 | |||
137 | -- | Run the given sibling game and return its state. | ||
138 | execSiblingGame :: Game s a -> s -> Game t s | ||
139 | execSiblingGame 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. |
121 | gameIO :: IO a -> Game s a | 142 | gameIO :: IO a -> Game s a |
122 | gameIO = lift . lift | 143 | gameIO = 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. |
212 | rot :: Float -> Matrix3 | 212 | rotate :: Float -> Matrix3 |
213 | rot angle = mat3 | 213 | rotate 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. |
264 | transl :: Float -> Float -> Float -> Matrix4 | 264 | translate :: Float -> Float -> Float -> Matrix4 |
265 | transl x y z = mat4 | 265 | translate 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. |
272 | translv :: Vector3 -> Matrix4 | 272 | translatev :: Vector3 -> Matrix4 |
273 | translv v = mat4 | 273 | translatev 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. |
281 | rotX :: Float -> Matrix4 | 281 | rotateX :: Float -> Matrix4 |
282 | rotX angle = mat4 | 282 | rotateX 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. |
293 | rotY :: Float -> Matrix4 | 293 | rotateY :: Float -> Matrix4 |
294 | rotY angle = mat4 | 294 | rotateY 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. |
305 | rotZ :: Float -> Matrix4 | 305 | rotateZ :: Float -> Matrix4 |
306 | rotZ angle = mat4 | 306 | rotateZ 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 | ||
44 | instance Rotational Transform3 Vector3 Rotation3 where | 44 | instance 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 | ||
170 | instance Storable Vector3 where | 170 | instance 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 @@ | |||
1 | module 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 | ) | ||
10 | where | ||
11 | |||
12 | import Spear.Render.Core.Buffer | ||
13 | import Spear.Render.Core.Constants | ||
14 | import Spear.Render.Core.Geometry | ||
15 | import Spear.Render.Core.Pipeline | ||
16 | import Spear.Render.Core.Shader | ||
17 | import 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 @@ | |||
1 | module Spear.Render.Core.Buffer | ||
2 | ( | ||
3 | BufferData(..) | ||
4 | , BufferDesc(..) | ||
5 | , makeBufferAndView | ||
6 | , makeBuffer | ||
7 | , deleteBuffer | ||
8 | , updateBuffer | ||
9 | ) | ||
10 | where | ||
11 | |||
12 | import Spear.Game | ||
13 | import Spear.Math.Vector | ||
14 | import Spear.Render.Core.State | ||
15 | |||
16 | import Control.Monad (void) | ||
17 | import Data.HashMap as HashMap | ||
18 | import Data.Word | ||
19 | import Foreign.C.Types | ||
20 | import Foreign.Marshal.Alloc | ||
21 | import Foreign.Marshal.Array | ||
22 | import Foreign.Ptr | ||
23 | import Foreign.Storable | ||
24 | import Graphics.GL.Core46 | ||
25 | import Unsafe.Coerce | ||
26 | |||
27 | |||
28 | data BufferData | ||
29 | = BufferDataUntyped (Ptr Word8) GLuint | ||
30 | | BufferDataVec2 [Vector2] | ||
31 | | BufferDataVec3 [Vector3] | ||
32 | | BufferDataFloat [Float] | ||
33 | | BufferDataU8 [Word8] | ||
34 | | BufferDataU16 [Word16] | ||
35 | | BufferUninitialized | ||
36 | |||
37 | data BufferDesc = BufferDesc | ||
38 | { bufferDescUsage :: BufferUsage | ||
39 | , bufferDescType :: BufferType | ||
40 | , bufferDescData :: BufferData | ||
41 | } | ||
42 | |||
43 | |||
44 | makeBufferAndView :: BufferDesc -> Game RenderCoreState (BufferView a) | ||
45 | makeBufferAndView 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 | |||
54 | makeBuffer :: BufferDesc -> Game RenderCoreState Buffer | ||
55 | makeBuffer (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 | |||
64 | deleteBuffer :: Buffer -> Game RenderCoreState () | ||
65 | deleteBuffer 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. | ||
72 | updateBuffer :: Buffer -> BufferData -> IO () | ||
73 | updateBuffer 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 | |||
83 | deleteBuffer' :: GLuint -> IO () | ||
84 | deleteBuffer' handle = alloca $ \ptr -> do | ||
85 | poke ptr handle | ||
86 | glDeleteBuffers 1 ptr | ||
87 | |||
88 | uploadData :: BufferUsage -> BufferData -> IO () | ||
89 | uploadData 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 | |||
111 | toGLUsage :: BufferUsage -> GLenum | ||
112 | toGLUsage BufferStatic = GL_STATIC_DRAW | ||
113 | toGLUsage BufferDynamic = GL_DYNAMIC_DRAW | ||
114 | |||
115 | bufferDataSizeBytes :: BufferData -> GLuint | ||
116 | bufferDataSizeBytes 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 @@ | |||
1 | module Spear.Render.Core.Constants where | ||
2 | |||
3 | |||
4 | import Graphics.GL.Core46 | ||
5 | |||
6 | |||
7 | positionChannel = 0 :: GLuint | ||
8 | normalChannel = 1 :: GLuint | ||
9 | tangentChannel = 2 :: GLuint | ||
10 | texcoordsChannel = 3 :: GLuint | ||
11 | jointsChannel = 4 :: GLuint | ||
12 | weightsChannel = 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 @@ | |||
1 | module Spear.Render.Core.Geometry | ||
2 | ( | ||
3 | newGeometryDesc | ||
4 | , makeGeometry | ||
5 | , deleteGeometry | ||
6 | , renderGeometry | ||
7 | , setPositions | ||
8 | ) | ||
9 | where | ||
10 | |||
11 | |||
12 | import Spear.Game | ||
13 | import Spear.Math.Vector.Vector3 | ||
14 | import Spear.Render.Core.Buffer | ||
15 | import Spear.Render.Core.Constants | ||
16 | import Spear.Render.Core.State | ||
17 | |||
18 | import Data.HashMap as HashMap | ||
19 | import Data.IORef | ||
20 | import Foreign.Marshal.Alloc | ||
21 | import Foreign.Storable | ||
22 | import Graphics.GL.Core46 | ||
23 | import Unsafe.Coerce | ||
24 | |||
25 | |||
26 | newGeometryDesc :: GeometryDesc | ||
27 | newGeometryDesc = 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 | |||
41 | makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry | ||
42 | makeGeometry 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 | |||
55 | deleteGeometry :: Geometry -> Game RenderCoreState () | ||
56 | deleteGeometry geometry = do | ||
57 | modifyGameState (\state -> state { | ||
58 | geometries = HashMap.delete (geometryVao geometry) (geometries state) }) | ||
59 | release geometry | ||
60 | |||
61 | renderGeometry :: Geometry -> IO () | ||
62 | renderGeometry 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 | |||
74 | setPositions :: Geometry -> [Vector3] -> IO () | ||
75 | setPositions 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 | |||
87 | deleteGeometry' :: GLenum -> IO () | ||
88 | deleteGeometry' handle = alloca $ \ptr -> do | ||
89 | poke ptr handle | ||
90 | glDeleteVertexArrays 1 ptr | ||
91 | |||
92 | updateGeometry :: Geometry -> (GeometryDesc -> GeometryDesc) -> IO () | ||
93 | updateGeometry geometry update = do | ||
94 | desc <- readIORef $ geometryDesc geometry | ||
95 | writeIORef (geometryDesc geometry) (update desc) | ||
96 | |||
97 | renderIndexed :: BufferView a -> GLenum -> GLsizei -> GLenum -> IO () | ||
98 | renderIndexed 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 | |||
103 | configureVertexAttributes :: GeometryDesc -> IO () | ||
104 | configureVertexAttributes 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 | ||
130 | configureView :: BufferView a -> GLuint -> GLint -> GLenum -> GLboolean -> IO () | ||
131 | configureView 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 | |||
146 | toGLPrimitiveType :: PrimitiveType -> GLenum | ||
147 | toGLPrimitiveType 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 @@ | |||
1 | module 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 | ) | ||
14 | where | ||
15 | |||
16 | import Data.Bits ((.|.)) | ||
17 | import Data.List (foldl') | ||
18 | import Graphics.GL.Core46 | ||
19 | |||
20 | |||
21 | data BufferTarget | ||
22 | = ColourBuffer | ||
23 | | DepthBuffer | ||
24 | | StencilBuffer | ||
25 | |||
26 | |||
27 | clearBuffers :: [BufferTarget] -> IO () | ||
28 | clearBuffers = 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 | |||
35 | setBlending :: Bool -> IO () | ||
36 | setBlending enable = | ||
37 | if enable | ||
38 | then glEnable GL_BLEND >> glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA | ||
39 | else glDisable GL_BLEND | ||
40 | |||
41 | setClearColour :: (Float, Float, Float, Float) -> IO () | ||
42 | setClearColour (r,g,b,a) = glClearColor r g b a | ||
43 | |||
44 | setClearDepth :: Double -> IO () | ||
45 | setClearDepth = glClearDepth | ||
46 | |||
47 | setClearStencil :: Int -> IO () | ||
48 | setClearStencil = glClearStencil . fromIntegral | ||
49 | |||
50 | setCulling :: Bool -> IO () | ||
51 | setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE | ||
52 | |||
53 | setDepthMask :: Bool -> IO () | ||
54 | setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE) | ||
55 | |||
56 | setPolygonOffset :: Float -> Float -> IO () | ||
57 | setPolygonOffset 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 | |||
63 | setViewport :: | ||
64 | -- | x | ||
65 | Int -> | ||
66 | -- | y | ||
67 | Int -> | ||
68 | -- | width | ||
69 | Int -> | ||
70 | -- | height | ||
71 | Int -> | ||
72 | IO () | ||
73 | setViewport 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 @@ | |||
1 | module 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 | ) | ||
15 | where | ||
16 | |||
17 | import Spear.Game | ||
18 | import Spear.Math.Matrix4 | ||
19 | import Spear.Math.Vector | ||
20 | import Spear.Render.Core.State | ||
21 | |||
22 | import Control.Monad (mapM_) | ||
23 | import Data.Bits | ||
24 | import Data.Hashable | ||
25 | import Data.HashMap as HashMap | ||
26 | import Data.IORef | ||
27 | import Data.List (deleteBy, foldl', intercalate) | ||
28 | import Foreign.C.String | ||
29 | import Foreign.Marshal.Alloc | ||
30 | import Foreign.Marshal.Array | ||
31 | import Foreign.Marshal.Utils | ||
32 | import Foreign.Ptr | ||
33 | import Foreign.Storable | ||
34 | import Graphics.GL.Core46 | ||
35 | import Unsafe.Coerce | ||
36 | |||
37 | |||
38 | type Define = (String, String) | ||
39 | |||
40 | data ShaderSource | ||
41 | = ShaderFromString String | ||
42 | | ShaderFromFile FilePath | ||
43 | deriving Show | ||
44 | |||
45 | data ShaderDesc = ShaderDesc | ||
46 | { shaderDescType :: ShaderType | ||
47 | , shaderDescSource :: ShaderSource | ||
48 | , shaderDescDefines :: [Define] | ||
49 | } | ||
50 | |||
51 | |||
52 | compileShader :: ShaderDesc -> Game RenderCoreState Shader | ||
53 | compileShader (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 | |||
97 | compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram | ||
98 | compileShaderProgram 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 | |||
137 | deleteShader :: Shader -> Game RenderCoreState () | ||
138 | deleteShader shader = do | ||
139 | modifyGameState (\state -> state { | ||
140 | shaders = HashMap.delete (shaderHash shader) (shaders state) }) | ||
141 | release shader | ||
142 | |||
143 | deleteShaderProgram :: ShaderProgram -> Game RenderCoreState () | ||
144 | deleteShaderProgram program = do | ||
145 | modifyGameState (\state -> state { | ||
146 | shaderPrograms = HashMap.delete (shaderProgramHash program) (shaderPrograms state)}) | ||
147 | release program | ||
148 | |||
149 | activateShaderProgram :: ShaderProgram -> IO () | ||
150 | activateShaderProgram program = do | ||
151 | glUseProgram . shaderProgramHandle $ program | ||
152 | applyUniforms program | ||
153 | |||
154 | deactivateShaderProgram :: ShaderProgram -> IO () | ||
155 | deactivateShaderProgram _ = glUseProgram 0 | ||
156 | |||
157 | setUniform :: ShaderUniform -> ShaderProgram -> IO () | ||
158 | setUniform 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 | |||
164 | applyUniforms :: ShaderProgram -> IO () | ||
165 | applyUniforms 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 | |||
191 | glGetUniformLocation' :: GLuint -> String -> IO GLint | ||
192 | glGetUniformLocation' handle name = | ||
193 | withCString name $ \nameCStr -> | ||
194 | glGetUniformLocation (fromIntegral handle) (unsafeCoerce nameCStr) | ||
195 | |||
196 | deleteShader' :: GLuint -> IO () | ||
197 | deleteShader' = glDeleteShader | ||
198 | |||
199 | deleteShaderProgram' :: GLuint -> IO () | ||
200 | deleteShaderProgram' = glDeleteProgram | ||
201 | |||
202 | hashShaders :: [Shader] -> Int | ||
203 | hashShaders = foldl' hashF 0 | ||
204 | where hashF hash shader = (hash `shiftL` 32) .|. fromIntegral (shaderHandle shader) | ||
205 | |||
206 | toGLShaderType :: ShaderType -> GLenum | ||
207 | toGLShaderType VertexShader = GL_VERTEX_SHADER | ||
208 | toGLShaderType FragmentShader = GL_FRAGMENT_SHADER | ||
209 | toGLShaderType ComputeShader = GL_COMPUTE_SHADER | ||
210 | |||
211 | makeDefinesString :: [Define] -> String | ||
212 | makeDefinesString defines = intercalate "\n" body ++ "\n" | ||
213 | where body = (\(name, value) -> "#define " ++ name ++ " " ++ value) <$> defines | ||
214 | |||
215 | -- Header prepended to all shaders. | ||
216 | header = "#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 @@ | |||
1 | module Spear.Render.Core.State where | ||
2 | |||
3 | import Spear.Game | ||
4 | import Spear.Math.Matrix4 | ||
5 | import Spear.Math.Vector | ||
6 | |||
7 | import Data.HashMap as HashMap | ||
8 | import Data.IORef | ||
9 | import Data.Word | ||
10 | import Graphics.GL.Core46 | ||
11 | |||
12 | |||
13 | |||
14 | data BufferType | ||
15 | = BufferUntyped | ||
16 | | Buffer2d | ||
17 | | Buffer3d | ||
18 | | Buffer4d | ||
19 | | BufferFloat | ||
20 | | BufferU8 | ||
21 | | BufferU16 | ||
22 | |||
23 | data BufferUsage | ||
24 | = BufferStatic | ||
25 | | BufferDynamic | ||
26 | |||
27 | -- | A data buffer (e.g., vertex attributes, indices). | ||
28 | data Buffer = Buffer | ||
29 | { bufferHandle :: GLuint | ||
30 | , bufferResource :: Resource | ||
31 | , bufferType :: BufferType | ||
32 | , bufferUsage :: BufferUsage | ||
33 | } | ||
34 | |||
35 | -- | A buffer view. | ||
36 | data BufferView a = BufferView | ||
37 | { bufferViewBuffer :: Buffer | ||
38 | , bufferViewOffsetBytes :: GLuint | ||
39 | , bufferViewSizeBytes :: GLuint | ||
40 | , bufferViewStrideBytes :: GLsizei | ||
41 | } | ||
42 | |||
43 | |||
44 | data Positions | ||
45 | = Positions2d (BufferView Vector2) | ||
46 | | Positions3d (BufferView Vector3) | ||
47 | |||
48 | data Joints | ||
49 | = JointsU8 (BufferView Word8) | ||
50 | | JointsU16 (BufferView Word16) | ||
51 | |||
52 | data Weights | ||
53 | = WeightsU8 (BufferView Word8) | ||
54 | | WeightsU16 (BufferView Word16) | ||
55 | | WeightsFloat (BufferView Float) | ||
56 | |||
57 | data Indices | ||
58 | = IndicesU8 (BufferView Word8) | ||
59 | | IndicesU16 (BufferView Word16) | ||
60 | |||
61 | data PrimitiveType | ||
62 | = Triangles | ||
63 | | TriangleFan | ||
64 | | TriangleStrip | ||
65 | |||
66 | -- | A geometry descriptor. | ||
67 | data 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. | ||
84 | data Geometry = Geometry | ||
85 | { geometryVao :: GLuint | ||
86 | , geometryResource :: Resource | ||
87 | , geometryDesc :: IORef GeometryDesc | ||
88 | } | ||
89 | |||
90 | |||
91 | -- | A shader. | ||
92 | data Shader = Shader | ||
93 | { shaderHandle :: GLuint | ||
94 | , shaderResource :: Resource | ||
95 | , shaderType :: ShaderType | ||
96 | , shaderHash :: Int | ||
97 | } | ||
98 | |||
99 | data ShaderType | ||
100 | = VertexShader | ||
101 | | FragmentShader | ||
102 | | ComputeShader | ||
103 | deriving (Eq, Show) | ||
104 | |||
105 | -- | A shader uniform. | ||
106 | data 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. | ||
114 | data 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. | ||
126 | data RenderCoreState = RenderCoreState | ||
127 | { buffers :: Map GLuint Buffer | ||
128 | , geometries :: Map GLuint Geometry | ||
129 | , shaders :: Map ShaderHash Shader | ||
130 | , shaderPrograms :: Map ShaderProgramHash ShaderProgram | ||
131 | } | ||
132 | |||
133 | type ShaderHash = Int | ||
134 | type ShaderProgramHash = Int | ||
135 | |||
136 | |||
137 | |||
138 | instance ResourceClass Buffer where | ||
139 | getResource = bufferResource | ||
140 | |||
141 | instance ResourceClass Geometry where | ||
142 | getResource = geometryResource | ||
143 | |||
144 | instance ResourceClass Shader where | ||
145 | getResource = shaderResource | ||
146 | |||
147 | instance ResourceClass ShaderProgram where | ||
148 | getResource = shaderProgramResource | ||
149 | |||
150 | |||
151 | newRenderCoreState :: RenderCoreState | ||
152 | newRenderCoreState = 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 | |||
3 | module 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 | ) | ||
23 | where | ||
24 | |||
25 | |||
26 | import Spear.Game | ||
27 | import Spear.Math.Algebra | ||
28 | import Spear.Math.Matrix4 as Matrix4 | ||
29 | import Spear.Math.Vector | ||
30 | import Spear.Prelude | ||
31 | import Spear.Render.Core.Buffer | ||
32 | import Spear.Render.Core.Geometry | ||
33 | import Spear.Render.Core.Shader | ||
34 | import Spear.Render.Core.State hiding (shaders) | ||
35 | |||
36 | import Control.Monad (unless) | ||
37 | import Data.List (foldl') | ||
38 | |||
39 | |||
40 | data ImmRenderState = ImmRenderState | ||
41 | { shaders :: [Shader] | ||
42 | , shader :: ShaderProgram | ||
43 | , triangles :: Geometry | ||
44 | , matrixStack :: [Matrix4] -- Pre-multiplied matrices. Never empty. | ||
45 | } | ||
46 | |||
47 | |||
48 | newImmRenderer :: Game RenderCoreState ImmRenderState | ||
49 | newImmRenderer = 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 | |||
73 | deleteImmRenderer :: ImmRenderState -> Game RenderCoreState () | ||
74 | deleteImmRenderer 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 | |||
82 | immStart :: Game ImmRenderState () | ||
83 | immStart = do | ||
84 | state <- getGameState | ||
85 | gameIO $ activateShaderProgram (shader state) | ||
86 | |||
87 | immEnd :: Game ImmRenderState () | ||
88 | immEnd = do | ||
89 | state <- getGameState | ||
90 | gameIO $ deactivateShaderProgram (shader state) | ||
91 | |||
92 | immDrawTriangles :: [Vector3] -> Game ImmRenderState () | ||
93 | immDrawTriangles 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. | ||
103 | immDrawQuads :: [(Vector3, Vector3, Vector3, Vector3)] -> Game ImmRenderState () | ||
104 | immDrawQuads quads = immDrawTriangles triangles | ||
105 | where | ||
106 | triangles = concatMap toTriangles quads | ||
107 | toTriangles (p0, p1, p2, p3) = [p0, p1, p2, p0, p2, p3] | ||
108 | |||
109 | immDrawTriangles2d :: [Vector2] -> Game ImmRenderState () | ||
110 | immDrawTriangles2d = immDrawTriangles . (<$>) to3d | ||
111 | |||
112 | immDrawQuads2d :: [(Vector2, Vector2, Vector2, Vector2)] -> Game ImmRenderState () | ||
113 | immDrawQuads2d = | ||
114 | immDrawQuads . (<$>) (\(p0, p1, p2, p3) -> (to3d p0, to3d p1, to3d p2, to3d p3)) | ||
115 | |||
116 | immLoadIdentity :: Game ImmRenderState () | ||
117 | immLoadIdentity = modifyGameState $ \state -> state { | ||
118 | matrixStack = [Matrix4.id] } | ||
119 | |||
120 | immTranslate :: Vector3 -> Game ImmRenderState () | ||
121 | immTranslate vector = modifyGameState $ pushMatrix (Matrix4.translatev vector) | ||
122 | |||
123 | immPushMatrix :: Matrix4 -> Game ImmRenderState () | ||
124 | immPushMatrix matrix = modifyGameState $ pushMatrix matrix | ||
125 | |||
126 | immPopMatrix :: Game ImmRenderState () | ||
127 | immPopMatrix = 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 | |||
132 | immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a | ||
133 | immPreservingMatrix f = do | ||
134 | originalStack <- matrixStack <$> getGameState | ||
135 | result <- f | ||
136 | modifyGameState $ \state -> state { matrixStack = originalStack } | ||
137 | return result | ||
138 | |||
139 | immSetColour :: Vector4 -> Game ImmRenderState () | ||
140 | immSetColour colour = do | ||
141 | state <- getGameState | ||
142 | gameIO $ setUniform (Vec4Uniform "Colour" colour) (shader state) | ||
143 | |||
144 | immSetModelMatrix :: Matrix4 -> Game ImmRenderState () | ||
145 | immSetModelMatrix model = do | ||
146 | state <- getGameState | ||
147 | gameIO $ setUniform (Mat4Uniform "Model" model) (shader state) | ||
148 | |||
149 | immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState () | ||
150 | immSetViewProjectionMatrix viewProjection = do | ||
151 | state <- getGameState | ||
152 | gameIO $ setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state) | ||
153 | |||
154 | -- Private | ||
155 | |||
156 | pushMatrix :: Matrix4 -> ImmRenderState -> ImmRenderState | ||
157 | pushMatrix matrix state = state { | ||
158 | matrixStack = matrix * head (matrixStack state) : matrixStack state } | ||
159 | |||
160 | loadMatrixStack :: Game ImmRenderState () | ||
161 | loadMatrixStack = do | ||
162 | state <- getGameState | ||
163 | immSetModelMatrix (head $ matrixStack state) | ||
164 | |||
165 | to3d :: Vector2 -> Vector3 | ||
166 | to3d (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 | |||
185 | rotateModel :: Rotation -> Model -> Model | 185 | rotateModel :: Rotation -> Model -> Model |
186 | rotateModel (Rotation ax ay az order) model = | 186 | rotateModel (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 @@ | |||
1 | module Spear.Window | 1 | module 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 | ) |
32 | where | 31 | where |
33 | 32 | ||
33 | import Spear.Game | ||
34 | |||
34 | import Control.Concurrent.MVar | 35 | import Control.Concurrent.MVar |
35 | import Control.Exception | 36 | import Control.Exception |
36 | import Control.Monad (foldM, unless, void, when) | 37 | import Control.Monad (foldM, unless, void, when) |
37 | import Data.Functor ((<&>)) | 38 | import Data.Functor ((<&>)) |
38 | import Data.Maybe (fromJust, fromMaybe, isJust) | 39 | import Data.Maybe (fromJust, fromMaybe, isJust) |
39 | import qualified Graphics.UI.GLFW as GLFW | 40 | import qualified Graphics.UI.GLFW as GLFW |
40 | import Spear.Game | 41 | |
42 | |||
43 | -- OpenGL major and minor versions | ||
44 | (major, minor) = (4, 4) | ||
41 | 45 | ||
42 | type Width = Int | 46 | type Width = Int |
43 | 47 | ||
@@ -46,14 +50,14 @@ type Height = Int | |||
46 | -- | Window dimensions. | 50 | -- | Window dimensions. |
47 | type Dimensions = (Width, Height) | 51 | type Dimensions = (Width, Height) |
48 | 52 | ||
49 | -- | A pair specifying the desired OpenGL context, of the form (Major, Minor). | ||
50 | type Context = (Int, Int) | ||
51 | |||
52 | type WindowTitle = String | 53 | type WindowTitle = String |
53 | 54 | ||
54 | -- | Game initialiser. | 55 | -- | Game initialiser. |
55 | type Init s = Window -> Game () s | 56 | type Init s = Window -> Game () s |
56 | 57 | ||
58 | -- | Game finalizer. | ||
59 | type End s = Game s () | ||
60 | |||
57 | -- | Window exception. | 61 | -- | Window exception. |
58 | newtype WindowException = WindowException String deriving (Show) | 62 | newtype 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 | |||
81 | withWindow :: | 86 | withWindow :: |
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 |
88 | withWindow dim@(w, h) glVersion windowTitle init run = do | 93 | withWindow 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 | ||
102 | setup :: | 107 | setup :: |
103 | Dimensions -> | 108 | Dimensions -> |
104 | Context -> | ||
105 | Maybe WindowTitle -> | 109 | Maybe WindowTitle -> |
106 | IO Window | 110 | IO Window |
107 | setup (w, h) (major, minor) windowTitle = do | 111 | setup (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 |