diff options
-rw-r--r-- | Spear.cabal | 3 | ||||
-rw-r--r-- | Spear/App.hs | 62 | ||||
-rw-r--r-- | Spear/Window.hs | 147 | ||||
-rw-r--r-- | demos/pong/Main.hs | 15 | ||||
-rw-r--r-- | demos/pong/Pong.hs | 46 | ||||
-rw-r--r-- | demos/pong/pong.cabal | 2 |
6 files changed, 146 insertions, 129 deletions
diff --git a/Spear.cabal b/Spear.cabal index 4c75dd8..07894c4 100644 --- a/Spear.cabal +++ b/Spear.cabal | |||
@@ -28,7 +28,8 @@ library | |||
28 | vector -any, | 28 | vector -any, |
29 | array -any | 29 | array -any |
30 | 30 | ||
31 | exposed-modules: Spear.Assets.Image | 31 | exposed-modules: Spear.App |
32 | Spear.Assets.Image | ||
32 | Spear.Assets.Model | 33 | Spear.Assets.Model |
33 | Spear.Game | 34 | Spear.Game |
34 | Spear.GL | 35 | Spear.GL |
diff --git a/Spear/App.hs b/Spear/App.hs new file mode 100644 index 0000000..dc17dec --- /dev/null +++ b/Spear/App.hs | |||
@@ -0,0 +1,62 @@ | |||
1 | module Spear.App | ||
2 | ( Elapsed, | ||
3 | Dt, | ||
4 | Step, | ||
5 | loop, | ||
6 | ) | ||
7 | where | ||
8 | |||
9 | import Control.Monad | ||
10 | import GHC.Float | ||
11 | import Spear.Game | ||
12 | import Spear.Sys.Timer as Timer | ||
13 | import Spear.Window | ||
14 | |||
15 | maxFPS = 60 | ||
16 | |||
17 | -- | Time elapsed since the application started. | ||
18 | type Elapsed = Double | ||
19 | |||
20 | -- | Time elapsed since the last frame. | ||
21 | type Dt = Float | ||
22 | |||
23 | -- | Return true if the application should continue running, false otherwise. | ||
24 | type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool | ||
25 | |||
26 | -- | Enter the main application loop. | ||
27 | loop :: Step s -> Window -> Game s () | ||
28 | loop step window = do | ||
29 | let ddt = 1.0 / fromIntegral maxFPS -- Desired delta time. | ||
30 | frameTimer <- gameIO $ start newTimer | ||
31 | controlTimer <- gameIO $ start newTimer | ||
32 | loop' window ddt frameTimer controlTimer 0 step | ||
33 | return () | ||
34 | |||
35 | loop' :: | ||
36 | Window -> | ||
37 | Dt -> | ||
38 | Timer -> | ||
39 | Timer -> | ||
40 | Elapsed -> | ||
41 | Step s -> | ||
42 | Game s () | ||
43 | loop' window ddt frameTimer controlTimer elapsed step = do | ||
44 | controlTimer' <- gameIO $ tick controlTimer | ||
45 | frameTimer' <- gameIO $ tick frameTimer | ||
46 | let dt = getDelta frameTimer' | ||
47 | let elapsed' = elapsed + float2Double dt | ||
48 | inputEvents <- gameIO $ pollEvents window | ||
49 | continue <- step elapsed' dt inputEvents | ||
50 | gameIO $ swapBuffers window | ||
51 | close <- gameIO $ shouldWindowClose window | ||
52 | controlTimer'' <- gameIO $ tick controlTimer' | ||
53 | let dt = getDelta controlTimer'' | ||
54 | when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) | ||
55 | when (continue && not close) $ | ||
56 | loop' | ||
57 | window | ||
58 | ddt | ||
59 | frameTimer' | ||
60 | controlTimer'' | ||
61 | elapsed' | ||
62 | step | ||
diff --git a/Spear/Window.hs b/Spear/Window.hs index 85a3dc8..a6471b0 100644 --- a/Spear/Window.hs +++ b/Spear/Window.hs | |||
@@ -3,7 +3,6 @@ module Spear.Window | |||
3 | Dimensions, | 3 | Dimensions, |
4 | Context, | 4 | Context, |
5 | WindowTitle, | 5 | WindowTitle, |
6 | FrameCap, | ||
7 | 6 | ||
8 | -- * Window | 7 | -- * Window |
9 | Window, | 8 | Window, |
@@ -11,14 +10,9 @@ module Spear.Window | |||
11 | Height, | 10 | Height, |
12 | Init, | 11 | Init, |
13 | withWindow, | 12 | withWindow, |
14 | events, | 13 | pollEvents, |
15 | 14 | shouldWindowClose, | |
16 | -- * Animation | 15 | swapBuffers, |
17 | Elapsed, | ||
18 | Dt, | ||
19 | Step, | ||
20 | loop, | ||
21 | GLFW.swapBuffers, | ||
22 | 16 | ||
23 | -- * Input | 17 | -- * Input |
24 | whenKeyDown, | 18 | whenKeyDown, |
@@ -37,16 +31,9 @@ where | |||
37 | import Control.Concurrent.MVar | 31 | import Control.Concurrent.MVar |
38 | import Control.Exception | 32 | import Control.Exception |
39 | import Control.Monad (foldM, unless, void, when) | 33 | import Control.Monad (foldM, unless, void, when) |
40 | import Control.Monad.IO.Class | ||
41 | import Data.Char (ord) | ||
42 | import Data.Maybe (fromJust, fromMaybe, isJust) | 34 | import Data.Maybe (fromJust, fromMaybe, isJust) |
43 | import GHC.Float | ||
44 | import qualified Graphics.Rendering.OpenGL as GL | ||
45 | import qualified Graphics.UI.GLFW as GLFW | 35 | import qualified Graphics.UI.GLFW as GLFW |
46 | import Spear.Game | 36 | import Spear.Game |
47 | import Spear.Sys.Timer as Timer | ||
48 | |||
49 | maxFPS = 60 | ||
50 | 37 | ||
51 | type Width = Int | 38 | type Width = Int |
52 | 39 | ||
@@ -55,13 +42,21 @@ type Height = Int | |||
55 | -- | Window dimensions. | 42 | -- | Window dimensions. |
56 | type Dimensions = (Width, Height) | 43 | type Dimensions = (Width, Height) |
57 | 44 | ||
58 | -- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). | 45 | -- | A pair specifying the desired OpenGL context, of the form (Major, Minor). |
59 | type Context = (Int, Int) | 46 | type Context = (Int, Int) |
60 | 47 | ||
61 | type WindowTitle = String | 48 | type WindowTitle = String |
62 | 49 | ||
63 | type CloseRequest = MVar Bool | 50 | type CloseRequest = MVar Bool |
64 | 51 | ||
52 | -- | Game initialiser. | ||
53 | type Init s = Window -> Game () s | ||
54 | |||
55 | -- | Window exception. | ||
56 | newtype WindowException = WindowException String deriving (Show) | ||
57 | |||
58 | instance Exception WindowException | ||
59 | |||
65 | -- | A window. | 60 | -- | A window. |
66 | data Window = Window | 61 | data Window = Window |
67 | { glfwWindow :: GLFW.Window, | 62 | { glfwWindow :: GLFW.Window, |
@@ -69,19 +64,6 @@ data Window = Window | |||
69 | inputEvents :: MVar [InputEvent] | 64 | inputEvents :: MVar [InputEvent] |
70 | } | 65 | } |
71 | 66 | ||
72 | -- | Poll the window's events. | ||
73 | events :: MonadIO m => Window -> m [InputEvent] | ||
74 | events window = liftIO $ do | ||
75 | es <- | ||
76 | tryTakeMVar (inputEvents window) >>= \xs -> case xs of | ||
77 | Nothing -> return [] | ||
78 | Just es -> return es | ||
79 | putMVar (inputEvents window) [] | ||
80 | return es | ||
81 | |||
82 | -- | Game initialiser. | ||
83 | type Init s = Window -> Game () s | ||
84 | |||
85 | withWindow :: | 67 | withWindow :: |
86 | Dimensions -> | 68 | Dimensions -> |
87 | Context -> | 69 | Context -> |
@@ -91,8 +73,10 @@ withWindow :: | |||
91 | IO a | 73 | IO a |
92 | withWindow dim@(w, h) glVersion windowTitle init run = do | 74 | withWindow dim@(w, h) glVersion windowTitle init run = do |
93 | flip runGame' () $ do | 75 | flip runGame' () $ do |
94 | glfwInit | 76 | window <- gameIO $ do |
95 | window <- setup dim glVersion windowTitle | 77 | success <- GLFW.init |
78 | unless success $ throw (WindowException "GLFW.initialize failed") | ||
79 | setup dim glVersion windowTitle | ||
96 | gameIO $ GLFW.makeContextCurrent (Just . glfwWindow $ window) | 80 | gameIO $ GLFW.makeContextCurrent (Just . glfwWindow $ window) |
97 | gameState <- init window | 81 | gameState <- init window |
98 | result <- evalSubGame (run window) gameState | 82 | result <- evalSubGame (run window) gameState |
@@ -105,86 +89,47 @@ setup :: | |||
105 | Dimensions -> | 89 | Dimensions -> |
106 | Context -> | 90 | Context -> |
107 | Maybe WindowTitle -> | 91 | Maybe WindowTitle -> |
108 | Game s Window | 92 | IO Window |
109 | setup (w, h) (major, minor) windowTitle = do | 93 | setup (w, h) (major, minor) windowTitle = do |
110 | closeRequest <- gameIO newEmptyMVar | 94 | closeRequest <- newEmptyMVar |
111 | inputEvents <- gameIO newEmptyMVar | 95 | inputEvents <- newEmptyMVar |
112 | let onResize' = onResize inputEvents | 96 | let onResize' = onResize inputEvents |
113 | let title = fromMaybe "" windowTitle | 97 | let title = fromMaybe "" windowTitle |
114 | let monitor = Nothing | 98 | let monitor = Nothing |
115 | maybeWindow <- gameIO $ do | 99 | maybeWindow <- do |
116 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major | 100 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major |
117 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor | 101 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor |
118 | when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Compat | 102 | when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Compat |
119 | GLFW.createWindow w h title monitor Nothing | 103 | GLFW.createWindow w h title monitor Nothing |
120 | unless (isJust maybeWindow) $ gameError "GLFW.openWindow failed" | 104 | unless (isJust maybeWindow) $ throwIO (WindowException "GLFW.openWindow failed") |
121 | let window = fromJust maybeWindow | 105 | let window = fromJust maybeWindow |
122 | liftIO $ do | 106 | GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest |
123 | GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest | 107 | GLFW.setWindowSizeCallback window . Just $ onResize' |
124 | GLFW.setWindowSizeCallback window . Just $ onResize' | 108 | GLFW.setKeyCallback window . Just $ onKey inputEvents |
125 | GLFW.setKeyCallback window . Just $ onKey inputEvents | 109 | GLFW.setCharCallback window . Just $ onChar inputEvents |
126 | GLFW.setCharCallback window . Just $ onChar inputEvents | 110 | GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents |
127 | GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents | 111 | onMouseMove inputEvents >>= GLFW.setCursorPosCallback window . Just |
128 | onMouseMove inputEvents >>= GLFW.setCursorPosCallback window . Just | 112 | onResize' window w h |
129 | onResize' window w h | ||
130 | return $ Spear.Window.Window window closeRequest inputEvents | 113 | return $ Spear.Window.Window window closeRequest inputEvents |
131 | 114 | ||
132 | glfwInit :: Game s () | 115 | -- | Poll the window's events. |
133 | glfwInit = do | 116 | pollEvents :: Window -> IO [InputEvent] |
134 | result <- gameIO GLFW.init | 117 | pollEvents window = do |
135 | if result then return () else gameError "GLFW.initialize failed" | 118 | GLFW.pollEvents |
136 | 119 | events <- | |
137 | -- | Time elapsed since the application started. | 120 | tryTakeMVar (inputEvents window) >>= \xs -> case xs of |
138 | type Elapsed = Double | 121 | Nothing -> return [] |
139 | 122 | Just events -> return events | |
140 | -- | Time elapsed since the last frame. | 123 | putMVar (inputEvents window) [] |
141 | type Dt = Float | 124 | return events |
142 | 125 | ||
143 | -- | Return true if the application should continue running, false otherwise. | 126 | -- | Return true when the user requests to close the window. |
144 | type Step s = Elapsed -> Dt -> Game s Bool | 127 | shouldWindowClose :: Window -> IO Bool |
145 | 128 | shouldWindowClose = getRequest . closeRequest | |
146 | -- | Maximum frame rate. | 129 | |
147 | type FrameCap = Int | 130 | -- | Swaps buffers. |
148 | 131 | swapBuffers :: Window -> IO () | |
149 | loop :: Step s -> Window -> Game s () | 132 | swapBuffers = GLFW.swapBuffers . glfwWindow |
150 | loop step window = do | ||
151 | let ddt = 1.0 / fromIntegral maxFPS | ||
152 | closeReq = closeRequest window | ||
153 | frameTimer <- gameIO $ start newTimer | ||
154 | controlTimer <- gameIO $ start newTimer | ||
155 | loop' window closeReq ddt frameTimer controlTimer 0 step | ||
156 | return () | ||
157 | |||
158 | loop' :: | ||
159 | Window -> | ||
160 | CloseRequest -> | ||
161 | Float -> | ||
162 | Timer -> | ||
163 | Timer -> | ||
164 | Elapsed -> | ||
165 | Step s -> | ||
166 | Game s () | ||
167 | loop' window closeRequest ddt frameTimer controlTimer elapsed step = do | ||
168 | controlTimer' <- gameIO $ tick controlTimer | ||
169 | frameTimer' <- gameIO $ tick frameTimer | ||
170 | let dt = getDelta frameTimer' | ||
171 | let elapsed' = elapsed + float2Double dt | ||
172 | gameIO GLFW.pollEvents | ||
173 | continue <- step elapsed' dt | ||
174 | gameIO . GLFW.swapBuffers $ glfwWindow window | ||
175 | close <- gameIO $ getRequest closeRequest | ||
176 | controlTimer'' <- gameIO $ tick controlTimer' | ||
177 | let dt = getDelta controlTimer'' | ||
178 | when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) | ||
179 | when (continue && not close) $ | ||
180 | loop' | ||
181 | window | ||
182 | closeRequest | ||
183 | ddt | ||
184 | frameTimer' | ||
185 | controlTimer'' | ||
186 | elapsed' | ||
187 | step | ||
188 | 133 | ||
189 | getRequest :: MVar Bool -> IO Bool | 134 | getRequest :: MVar Bool -> IO Bool |
190 | getRequest mvar = | 135 | getRequest mvar = |
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs index 3563c30..a9dfcdd 100644 --- a/demos/pong/Main.hs +++ b/demos/pong/Main.hs | |||
@@ -4,6 +4,7 @@ import Data.Maybe (mapMaybe) | |||
4 | import Graphics.Rendering.OpenGL.GL (($=)) | 4 | import Graphics.Rendering.OpenGL.GL (($=)) |
5 | import qualified Graphics.Rendering.OpenGL.GL as GL | 5 | import qualified Graphics.Rendering.OpenGL.GL as GL |
6 | import Pong | 6 | import Pong |
7 | import Spear.App | ||
7 | import Spear.Game | 8 | import Spear.Game |
8 | import Spear.Math.AABB | 9 | import Spear.Math.AABB |
9 | import Spear.Math.Spatial2 | 10 | import Spear.Math.Spatial2 |
@@ -27,19 +28,17 @@ initGame window = do | |||
27 | GL.loadIdentity | 28 | GL.loadIdentity |
28 | return $ GameState window newWorld | 29 | return $ GameState window newWorld |
29 | 30 | ||
30 | step :: Elapsed -> Dt -> Game GameState Bool | 31 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool |
31 | step elapsed dt = do | 32 | step elapsed dt inputEvents = do |
32 | --gameIO $ putStrLn "Tick" | ||
33 | gs <- getGameState | 33 | gs <- getGameState |
34 | evts <- events (window gs) | 34 | gameIO . process $ inputEvents |
35 | gameIO . process $ evts | 35 | let events = translate inputEvents |
36 | let evts' = translate evts | ||
37 | modifyGameState $ \gs -> | 36 | modifyGameState $ \gs -> |
38 | gs | 37 | gs |
39 | { world = stepWorld elapsed dt evts' (world gs) | 38 | { world = stepWorld elapsed dt events (world gs) |
40 | } | 39 | } |
41 | getGameState >>= \gs -> gameIO . render $ world gs | 40 | getGameState >>= \gs -> gameIO . render $ world gs |
42 | return (not $ exitRequested evts) | 41 | return (not $ exitRequested inputEvents) |
43 | 42 | ||
44 | render world = do | 43 | render world = do |
45 | GL.clear [GL.ColorBuffer] | 44 | GL.clear [GL.ColorBuffer] |
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs index 232c69a..906e89b 100644 --- a/demos/pong/Pong.hs +++ b/demos/pong/Pong.hs | |||
@@ -14,6 +14,22 @@ import Spear.Math.Spatial2 | |||
14 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
15 | import Spear.Step | 15 | import Spear.Step |
16 | 16 | ||
17 | -- Configuration | ||
18 | |||
19 | padSize = vec2 0.05 0.02 | ||
20 | |||
21 | ballSize = 0.01 | ||
22 | |||
23 | ballVelocity = vec2 0.3 0.3 | ||
24 | |||
25 | playerSpeed = 0.7 | ||
26 | |||
27 | initialEnemyPos = vec2 0.5 0.9 | ||
28 | |||
29 | initialPlayerPos = vec2 0.5 0.1 | ||
30 | |||
31 | initialBallPos = vec2 0.5 0.5 | ||
32 | |||
17 | -- Game events | 33 | -- Game events |
18 | 34 | ||
19 | data GameEvent | 35 | data GameEvent |
@@ -43,21 +59,16 @@ update elapsed dt evts gos go = | |||
43 | let (go', s') = runStep (gostep go) elapsed dt gos evts go | 59 | let (go', s') = runStep (gostep go) elapsed dt gos evts go |
44 | in go' {gostep = s'} | 60 | in go' {gostep = s'} |
45 | 61 | ||
46 | ballBox :: AABB2 | 62 | ballBox, padBox :: AABB2 |
47 | ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01 | 63 | ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = ballSize |
48 | |||
49 | padSize = vec2 0.05 0.02 | ||
50 | |||
51 | padBox = AABB2 (- padSize) padSize | 64 | padBox = AABB2 (- padSize) padSize |
52 | 65 | ||
53 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) | 66 | obj2 = obj2FromVectors unitx2 unity2 |
54 | |||
55 | ballVelocity = Vector2 0.3 0.3 | ||
56 | 67 | ||
57 | newWorld = | 68 | newWorld = |
58 | [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity, | 69 | [ GameObject ballBox (obj2 initialBallPos) $ stepBall ballVelocity, |
59 | GameObject padBox (obj2 0.5 0.9) stepEnemy, | 70 | GameObject padBox (obj2 initialEnemyPos) stepEnemy, |
60 | GameObject padBox (obj2 0.5 0.1) stepPlayer | 71 | GameObject padBox (obj2 initialPlayerPos) stepPlayer |
61 | ] | 72 | ] |
62 | 73 | ||
63 | -- Ball steppers | 74 | -- Ball steppers |
@@ -110,8 +121,8 @@ stepPlayer = sfold moveGO .> clamp | |||
110 | 121 | ||
111 | moveGO = | 122 | moveGO = |
112 | mconcat | 123 | mconcat |
113 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0), | 124 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (- playerSpeed) 0), |
114 | switch StopRight sid MoveRight (moveGO' $ vec2 1 0) | 125 | switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) |
115 | ] | 126 | ] |
116 | 127 | ||
117 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 128 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
@@ -121,10 +132,9 @@ clamp :: Step s e GameObject GameObject | |||
121 | clamp = spure $ \go -> | 132 | clamp = spure $ \go -> |
122 | let p' = vec2 (clamp' x s (1 - s)) y | 133 | let p' = vec2 (clamp' x s (1 - s)) y |
123 | (Vector2 x y) = pos go | 134 | (Vector2 x y) = pos go |
124 | clamp' x a b = if x < a then a else if x > b then b else x | 135 | clamp' x a b |
136 | | x < a = a | ||
137 | | x > b = b | ||
138 | | otherwise = x | ||
125 | (Vector2 s _) = padSize | 139 | (Vector2 s _) = padSize |
126 | in setPos p' go | 140 | in setPos p' go |
127 | |||
128 | toDir True MoveLeft = vec2 (-1) 0 | ||
129 | toDir True MoveRight = vec2 1 0 | ||
130 | toDir _ _ = vec2 0 0 | ||
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal index 23ada51..aec96ee 100644 --- a/demos/pong/pong.cabal +++ b/demos/pong/pong.cabal | |||
@@ -17,5 +17,5 @@ cabal-version: >=1.8 | |||
17 | executable pong | 17 | executable pong |
18 | -- hs-source-dirs: src | 18 | -- hs-source-dirs: src |
19 | main-is: Main.hs | 19 | main-is: Main.hs |
20 | -- other-modules: | 20 | other-modules: Pong |
21 | build-depends: base, Spear, OpenGL | 21 | build-depends: base, Spear, OpenGL |