diff options
-rw-r--r-- | Demos/Pong/Main.hs | 16 | ||||
-rw-r--r-- | Demos/Pong/Pong.hs | 13 | ||||
-rw-r--r-- | Spear/App.hs | 2 | ||||
-rw-r--r-- | Spear/Step.hs | 41 | ||||
-rw-r--r-- | Spear/Window.hs | 36 |
5 files changed, 52 insertions, 56 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs index c768142..ee55622 100644 --- a/Demos/Pong/Main.hs +++ b/Demos/Pong/Main.hs | |||
@@ -14,6 +14,7 @@ import Spear.Render.Core.State | |||
14 | import Spear.Render.Immediate | 14 | import Spear.Render.Immediate |
15 | import Spear.Window | 15 | import Spear.Window |
16 | 16 | ||
17 | import Control.Monad (when) | ||
17 | import Data.Maybe (mapMaybe) | 18 | import Data.Maybe (mapMaybe) |
18 | 19 | ||
19 | 20 | ||
@@ -44,7 +45,8 @@ endGame = do | |||
44 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | 45 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool |
45 | step elapsed dt inputEvents = do | 46 | step elapsed dt inputEvents = do |
46 | gs <- getGameState | 47 | gs <- getGameState |
47 | let events = translateEvents inputEvents | 48 | events <- processInput (window gs) |
49 | --when (events /= []) $ gameIO . putStrLn $ show events | ||
48 | modifyGameState $ \gs -> | 50 | modifyGameState $ \gs -> |
49 | gs | 51 | gs |
50 | { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs) | 52 | { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs) |
@@ -112,11 +114,11 @@ resize (ResizeEvent w h) = | |||
112 | viewProjection = Matrix4.ortho left right bottom top (-1) 1 | 114 | viewProjection = Matrix4.ortho left right bottom top (-1) 1 |
113 | } | 115 | } |
114 | 116 | ||
115 | translateEvents = mapMaybe translateEvents' | 117 | |
116 | where translateEvents' (KeyDown KEY_A) = Just MoveLeft | 118 | processInput :: Window -> Game GameState [GameEvent] |
117 | translateEvents' (KeyDown KEY_D) = Just MoveRight | 119 | processInput window = processKeys window |
118 | translateEvents' (KeyUp KEY_A) = Just StopLeft | 120 | [ (KEY_A, MoveLeft) |
119 | translateEvents' (KeyUp KEY_D) = Just StopRight | 121 | , (KEY_D, MoveRight) |
120 | translateEvents' _ = Nothing | 122 | ] |
121 | 123 | ||
122 | exitRequested = elem (KeyDown KEY_ESC) | 124 | exitRequested = elem (KeyDown KEY_ESC) |
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs index 943682f..2bd9df1 100644 --- a/Demos/Pong/Pong.hs +++ b/Demos/Pong/Pong.hs | |||
@@ -40,9 +40,7 @@ initialBallPos = vec2 0.5 0.5 | |||
40 | data GameEvent | 40 | data GameEvent |
41 | = MoveLeft | 41 | = MoveLeft |
42 | | MoveRight | 42 | | MoveRight |
43 | | StopLeft | 43 | deriving (Eq, Ord, Show) |
44 | | StopRight | ||
45 | deriving (Eq, Ord) | ||
46 | 44 | ||
47 | -- Game objects | 45 | -- Game objects |
48 | 46 | ||
@@ -163,11 +161,10 @@ movePad = step $ \elapsed _ _ _ pad -> | |||
163 | 161 | ||
164 | stepPlayer = sfold moveGO .> clamp | 162 | stepPlayer = sfold moveGO .> clamp |
165 | 163 | ||
166 | moveGO = | 164 | moveGO = mconcat |
167 | mconcat | 165 | [ swhen MoveLeft $ moveGO' (vec2 (-playerSpeed) 0) |
168 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), | 166 | , swhen MoveRight $ moveGO' (vec2 playerSpeed 0) |
169 | switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) | 167 | ] |
170 | ] | ||
171 | 168 | ||
172 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 169 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
173 | moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) | 170 | moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) |
diff --git a/Spear/App.hs b/Spear/App.hs index 1a0095b..b0c7141 100644 --- a/Spear/App.hs +++ b/Spear/App.hs | |||
@@ -62,6 +62,8 @@ loop' window ddt inputTimer elapsed timeBudget app = do | |||
62 | let timeBudgetThisFrame = timeBudget + deltaTime timer | 62 | let timeBudgetThisFrame = timeBudget + deltaTime timer |
63 | let steps = timeBudgetThisFrame `div` ddt | 63 | let steps = timeBudgetThisFrame `div` ddt |
64 | 64 | ||
65 | --gameIO . putStrLn $ "Steps: " ++ show steps | ||
66 | |||
65 | continue <- and <$> forM [1..steps] (\i -> do | 67 | continue <- and <$> forM [1..steps] (\i -> do |
66 | let t = timeDeltaToSec $ elapsed + i * ddt | 68 | let t = timeDeltaToSec $ elapsed + i * ddt |
67 | let dt = timeDeltaToSec ddt | 69 | let dt = timeDeltaToSec ddt |
diff --git a/Spear/Step.hs b/Spear/Step.hs index cb4f71c..e767166 100644 --- a/Spear/Step.hs +++ b/Spear/Step.hs | |||
@@ -21,6 +21,7 @@ module Spear.Step | |||
21 | (.>), | 21 | (.>), |
22 | (<.), | 22 | (<.), |
23 | szip, | 23 | szip, |
24 | swhen, | ||
24 | switch, | 25 | switch, |
25 | multiSwitch, | 26 | multiSwitch, |
26 | ) | 27 | ) |
@@ -36,8 +37,8 @@ type Elapsed = Float | |||
36 | type Dt = Float | 37 | type Dt = Float |
37 | 38 | ||
38 | -- | A step function. | 39 | -- | A step function. |
39 | newtype Step state events input a = Step | 40 | newtype Step state events a b = Step |
40 | { runStep :: Elapsed -> Dt -> state -> events -> input -> (a, Step state events input a) | 41 | { runStep :: Elapsed -> Dt -> state -> events -> a -> (b, Step state events a b) |
41 | } | 42 | } |
42 | 43 | ||
43 | instance Functor (Step s e a) where | 44 | instance Functor (Step s e a) where |
@@ -73,29 +74,12 @@ ssnd = spure snd | |||
73 | 74 | ||
74 | -- | Construct a step that folds a given list of inputs. | 75 | -- | Construct a step that folds a given list of inputs. |
75 | -- | 76 | -- |
76 | -- The step is run N+1 times, where N is the size of the input list. | 77 | -- The step is run once per input, or not at all if the list is empty. |
77 | sfold :: Step s (Maybe e) a a -> Step s [e] a a | 78 | sfold :: Step s (Maybe e) a a -> Step s [e] a a |
78 | sfold s = Step $ \elapsed dt g es a -> | 79 | sfold s = Step $ \elapsed dt g es a -> |
79 | case es of | 80 | let (a', s') = foldl' f (a, s) es |
80 | [] -> | 81 | f (a, s) e = runStep s elapsed dt g (Just e) a |
81 | let (b', s') = runStep s elapsed dt g Nothing a | 82 | in (a', sfold s') |
82 | in (b', sfold s') | ||
83 | es -> | ||
84 | let (b', s') = sfold' elapsed dt g s a es | ||
85 | in (b', sfold s') | ||
86 | |||
87 | sfold' :: | ||
88 | Elapsed -> | ||
89 | Dt -> | ||
90 | s -> | ||
91 | Step s (Maybe e) a a -> | ||
92 | a -> | ||
93 | [e] -> | ||
94 | (a, Step s (Maybe e) a a) | ||
95 | sfold' elapsed dt g s a = foldl' f (a', s') | ||
96 | where | ||
97 | f (a, s) e = runStep s elapsed dt g (Just e) a | ||
98 | (a', s') = runStep s elapsed dt g Nothing a | ||
99 | 83 | ||
100 | -- Combinators | 84 | -- Combinators |
101 | 85 | ||
@@ -117,6 +101,17 @@ szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d -> | |||
117 | (b, s2') = s2 elapsed dt g e d | 101 | (b, s2') = s2 elapsed dt g e d |
118 | in (f a b, szip f s1' s2') | 102 | in (f a b, szip f s1' s2') |
119 | 103 | ||
104 | -- | Construct a step that is executed when the given event occurs. | ||
105 | swhen :: Eq e => e -> Step s () a a -> Step s (Maybe e) a a | ||
106 | swhen expectedEvent step = Step $ \elapsed dt state maybeEvent a -> | ||
107 | case maybeEvent of | ||
108 | Nothing -> (a, swhen expectedEvent step) | ||
109 | Just event -> | ||
110 | if event == expectedEvent | ||
111 | then let (a', step') = runStep step elapsed dt state () a | ||
112 | in (a', swhen expectedEvent step') | ||
113 | else (a, swhen expectedEvent step) | ||
114 | |||
120 | -- | Construct a step that switches between two steps based on input. | 115 | -- | Construct a step that switches between two steps based on input. |
121 | -- | 116 | -- |
122 | -- The initial step is the first one. | 117 | -- The initial step is the first one. |
diff --git a/Spear/Window.hs b/Spear/Window.hs index 20d7acc..be52080 100644 --- a/Spear/Window.hs +++ b/Spear/Window.hs | |||
@@ -183,12 +183,12 @@ onResize windowEvents window w h = modifyMVar_ windowEvents (return <$> const [R | |||
183 | 183 | ||
184 | onKey :: MVar [InputEvent] -> GLFW.KeyCallback | 184 | onKey :: MVar [InputEvent] -> GLFW.KeyCallback |
185 | onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key) | 185 | onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key) |
186 | onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key) | 186 | onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key) |
187 | onKey events window key _ GLFW.KeyState'Repeating _ = return () | 187 | onKey events window key _ GLFW.KeyState'Repeating _ = return () |
188 | 188 | ||
189 | onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback | 189 | onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback |
190 | onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button) | 190 | onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button) |
191 | onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button) | 191 | onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button) |
192 | 192 | ||
193 | onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback | 193 | onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback |
194 | onMouseMove oldPos events window x y = do | 194 | onMouseMove oldPos events window x y = do |
@@ -206,45 +206,45 @@ replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val | |||
206 | addEvent :: MVar [a] -> a -> IO () | 206 | addEvent :: MVar [a] -> a -> IO () |
207 | addEvent mvar val = | 207 | addEvent mvar val = |
208 | tryTakeMVar mvar >>= \xs -> case xs of | 208 | tryTakeMVar mvar >>= \xs -> case xs of |
209 | Nothing -> putMVar mvar [val] | 209 | Nothing -> putMVar mvar [val] -- >> (putStrLn $ show val) |
210 | Just events -> putMVar mvar (val : events) | 210 | Just events -> putMVar mvar (val : events) -- >> (putStrLn $ show (val:events)) |
211 | 211 | ||
212 | -- Input | 212 | -- Input |
213 | 213 | ||
214 | -- | Run the game action when the key is down. | 214 | -- | Run the game action when the key is down. |
215 | whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s () | 215 | whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s () |
216 | whenKeyDown = whenKeyInState (== GLFW.KeyState'Pressed) | 216 | whenKeyDown = whenKeyInState GLFW.KeyState'Pressed |
217 | 217 | ||
218 | -- | Run the game action when the key is up. | 218 | -- | Run the game action when the key is up. |
219 | whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s () | 219 | whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s () |
220 | whenKeyUp = whenKeyInState (== GLFW.KeyState'Released) | 220 | whenKeyUp = whenKeyInState GLFW.KeyState'Released |
221 | 221 | ||
222 | whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s () | 222 | whenKeyInState :: GLFW.KeyState -> GLFW.Window -> Key -> Game s a -> Game s () |
223 | whenKeyInState pred window key game = do | 223 | whenKeyInState state window key game = do |
224 | isDown <- fmap pred $ gameIO . GLFW.getKey window . toGLFWkey $ key | 224 | isDown <- fmap (==state) $ gameIO . GLFW.getKey window . toGLFWkey $ key |
225 | when isDown $ void game | 225 | when isDown $ void game |
226 | 226 | ||
227 | -- | Process the keyboard keys, returning those values for which their | 227 | -- | Check whether the given keys are pressed and return the value associated |
228 | -- corresponding key is pressed. | 228 | -- with each of the pressed keys. |
229 | processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a] | 229 | processKeys :: Window -> [(Key, a)] -> Game s [a] |
230 | processKeys window = foldM f [] | 230 | processKeys window = foldM f [] |
231 | where | 231 | where |
232 | f acc (key, result) = do | 232 | f acc (key, result) = do |
233 | isDown <- | 233 | isDown <- |
234 | fmap (== GLFW.KeyState'Pressed) $ | 234 | fmap (== GLFW.KeyState'Pressed) $ |
235 | gameIO . GLFW.getKey window . toGLFWkey $ | 235 | gameIO . GLFW.getKey (glfwWindow window) . toGLFWkey $ |
236 | key | 236 | key |
237 | return $ if isDown then result : acc else acc | 237 | return $ if isDown then result : acc else acc |
238 | 238 | ||
239 | -- | Process the mouse buttons, returning those values for which their | 239 | -- | Check whether the given buttons are pressed and return the value associated |
240 | -- corresponding button is pressed. | 240 | -- with each of the pressed buttons. |
241 | processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a] | 241 | processButtons :: Window -> [(MouseButton, a)] -> Game s [a] |
242 | processButtons window = foldM f [] | 242 | processButtons window = foldM f [] |
243 | where | 243 | where |
244 | f acc (button, result) = do | 244 | f acc (button, result) = do |
245 | isDown <- | 245 | isDown <- |
246 | fmap (== GLFW.MouseButtonState'Pressed) $ | 246 | fmap (== GLFW.MouseButtonState'Pressed) $ |
247 | gameIO . GLFW.getMouseButton window . toGLFWbutton $ | 247 | gameIO . GLFW.getMouseButton (glfwWindow window) . toGLFWbutton $ |
248 | button | 248 | button |
249 | return $ if isDown then result : acc else acc | 249 | return $ if isDown then result : acc else acc |
250 | 250 | ||