diff options
author | Jeanne-Kamikaze <jeannekamikaze@gmail.com> | 2013-08-10 17:24:17 +0200 |
---|---|---|
committer | Jeanne-Kamikaze <jeannekamikaze@gmail.com> | 2013-08-10 17:24:17 +0200 |
commit | e15a9cc51e31b5deb973d8583298aa130dd82b17 (patch) | |
tree | c7eca5402b85ccb9cb7de3928991f1b3a9d4e253 | |
parent | 04313774991dc503844ddd2c47529aca8280aa6c (diff) |
Added pong
-rw-r--r-- | .gitignore | 3 | ||||
-rw-r--r-- | Spear.cabal | 11 | ||||
-rw-r--r-- | Spear/App.hs | 10 | ||||
-rw-r--r-- | Spear/App/Application.hs | 139 | ||||
-rw-r--r-- | Spear/App/Input.hs | 265 | ||||
-rw-r--r-- | Spear/Game.hs | 7 | ||||
-rw-r--r-- | Spear/Math/AABB.hs | 4 | ||||
-rw-r--r-- | Spear/Math/Entity.hs | 33 | ||||
-rw-r--r-- | Spear/Math/MatrixUtils.hs | 9 | ||||
-rw-r--r-- | Spear/Math/Spatial2.hs | 210 | ||||
-rw-r--r-- | Spear/Math/Spatial3.hs | 270 | ||||
-rw-r--r-- | Spear/Math/Vector/Vector2.hs | 28 | ||||
-rw-r--r-- | Spear/Math/Vector/Vector3.hs | 2 | ||||
-rw-r--r-- | Spear/Math/Vector/Vector4.hs | 34 | ||||
-rw-r--r-- | Spear/Scene/GameObject.hs | 320 | ||||
-rw-r--r-- | Spear/Scene/Light.hs | 31 | ||||
-rw-r--r-- | Spear/Scene/Loader.hs | 73 | ||||
-rw-r--r-- | Spear/Scene/SceneResources.hs | 4 | ||||
-rw-r--r-- | Spear/Sys/Timer.hsc | 2 | ||||
-rw-r--r-- | Spear/Window.hs | 311 | ||||
-rw-r--r-- | demos/pong/LICENSE | 30 | ||||
-rw-r--r-- | demos/pong/Main.hs | 86 | ||||
-rw-r--r-- | demos/pong/Pong.hs | 174 | ||||
-rw-r--r-- | demos/pong/Setup.hs | 2 | ||||
-rw-r--r-- | demos/pong/pong.cabal | 21 |
25 files changed, 962 insertions, 1117 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8d5c25e --- /dev/null +++ b/.gitignore | |||
@@ -0,0 +1,3 @@ | |||
1 | demos/pong/dist/ | ||
2 | demos/pong/pong | ||
3 | dist/ | ||
diff --git a/Spear.cabal b/Spear.cabal index 0e52faf..ea5eafc 100644 --- a/Spear.cabal +++ b/Spear.cabal | |||
@@ -17,7 +17,7 @@ library | |||
17 | OpenGLRaw -any, | 17 | OpenGLRaw -any, |
18 | StateVar -any, | 18 | StateVar -any, |
19 | base -any, | 19 | base -any, |
20 | bytestring >= 0.10, | 20 | bytestring -any, |
21 | directory -any, | 21 | directory -any, |
22 | mtl -any, | 22 | mtl -any, |
23 | transformers -any, | 23 | transformers -any, |
@@ -27,10 +27,7 @@ library | |||
27 | vector -any, | 27 | vector -any, |
28 | array -any | 28 | array -any |
29 | 29 | ||
30 | exposed-modules: Spear.App | 30 | exposed-modules: Spear.Assets.Image |
31 | Spear.App.Application | ||
32 | Spear.App.Input | ||
33 | Spear.Assets.Image | ||
34 | Spear.Assets.Model | 31 | Spear.Assets.Model |
35 | Spear.Game | 32 | Spear.Game |
36 | Spear.GL | 33 | Spear.GL |
@@ -38,7 +35,6 @@ library | |||
38 | Spear.Math.Camera | 35 | Spear.Math.Camera |
39 | Spear.Math.Circle | 36 | Spear.Math.Circle |
40 | Spear.Math.Collision | 37 | Spear.Math.Collision |
41 | Spear.Math.Entity | ||
42 | Spear.Math.Frustum | 38 | Spear.Math.Frustum |
43 | Spear.Math.Matrix3 | 39 | Spear.Math.Matrix3 |
44 | Spear.Math.Matrix4 | 40 | Spear.Math.Matrix4 |
@@ -62,14 +58,13 @@ library | |||
62 | Spear.Render.Model | 58 | Spear.Render.Model |
63 | Spear.Render.Program | 59 | Spear.Render.Program |
64 | Spear.Render.StaticModel | 60 | Spear.Render.StaticModel |
65 | Spear.Scene.GameObject | ||
66 | Spear.Scene.Graph | 61 | Spear.Scene.Graph |
67 | Spear.Scene.Light | ||
68 | Spear.Scene.Loader | 62 | Spear.Scene.Loader |
69 | Spear.Scene.SceneResources | 63 | Spear.Scene.SceneResources |
70 | Spear.Sys.Store | 64 | Spear.Sys.Store |
71 | Spear.Sys.Store.ID | 65 | Spear.Sys.Store.ID |
72 | Spear.Sys.Timer | 66 | Spear.Sys.Timer |
67 | Spear.Window | ||
73 | 68 | ||
74 | exposed: True | 69 | exposed: True |
75 | 70 | ||
diff --git a/Spear/App.hs b/Spear/App.hs deleted file mode 100644 index 4057aa3..0000000 --- a/Spear/App.hs +++ /dev/null | |||
@@ -1,10 +0,0 @@ | |||
1 | module Spear.App | ||
2 | ( | ||
3 | module Spear.App.Application | ||
4 | , module Spear.App.Input | ||
5 | ) | ||
6 | where | ||
7 | |||
8 | |||
9 | import Spear.App.Application | ||
10 | import Spear.App.Input | ||
diff --git a/Spear/App/Application.hs b/Spear/App/Application.hs deleted file mode 100644 index 5886502..0000000 --- a/Spear/App/Application.hs +++ /dev/null | |||
@@ -1,139 +0,0 @@ | |||
1 | module Spear.App.Application | ||
2 | ( | ||
3 | -- * Setup | ||
4 | Dimensions | ||
5 | , Context | ||
6 | , WindowTitle | ||
7 | , SpearWindow | ||
8 | , Update | ||
9 | , Size(..) | ||
10 | , DisplayBits(..) | ||
11 | , WindowMode(..) | ||
12 | , WindowSizeCallback | ||
13 | , withWindow | ||
14 | -- * Main loop | ||
15 | , loop | ||
16 | , loopCapped | ||
17 | -- * Helpers | ||
18 | , swapBuffers | ||
19 | ) | ||
20 | where | ||
21 | |||
22 | import Spear.Game | ||
23 | import Spear.Sys.Timer as Timer | ||
24 | |||
25 | import Control.Concurrent.MVar | ||
26 | import Control.Monad (when) | ||
27 | import Control.Monad.IO.Class | ||
28 | import Graphics.UI.GLFW as GLFW | ||
29 | import Graphics.Rendering.OpenGL as GL | ||
30 | |||
31 | -- | Window dimensions. | ||
32 | type Dimensions = (Int, Int) | ||
33 | |||
34 | -- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). | ||
35 | type Context = (Int, Int) | ||
36 | |||
37 | type WindowTitle = String | ||
38 | |||
39 | -- Whether the user has closed the window. | ||
40 | type CloseRequested = MVar Bool | ||
41 | |||
42 | -- | Represents a window. | ||
43 | data SpearWindow = SpearWindow | ||
44 | { closeRequest :: CloseRequested | ||
45 | } | ||
46 | |||
47 | withWindow :: MonadIO m | ||
48 | => Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | ||
49 | -> WindowSizeCallback -> (SpearWindow -> Game () a) -> m (Either String a) | ||
50 | withWindow dim@(w,h) displayBits windowMode glVersion windowTitle onResize game = do | ||
51 | result <- liftIO . flip runGame () $ do | ||
52 | glfwInit | ||
53 | window <- setup dim displayBits windowMode glVersion windowTitle onResize | ||
54 | result <- evalSubGame (game window) () | ||
55 | gameIO GLFW.closeWindow | ||
56 | gameIO GLFW.terminate | ||
57 | return result | ||
58 | case result of | ||
59 | Left err -> return $ Left err | ||
60 | Right (a,_) -> return $ Right a | ||
61 | |||
62 | -- Set up an application 'SpearWindow'. | ||
63 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | ||
64 | -> WindowSizeCallback -> Game s SpearWindow | ||
65 | setup (w, h) displayBits windowMode (major, minor) wndTitle onResize = do | ||
66 | closeRequest <- gameIO $ newEmptyMVar | ||
67 | gameIO $ do | ||
68 | openWindowHint OpenGLVersionMajor major | ||
69 | openWindowHint OpenGLVersionMinor minor | ||
70 | openWindowHint OpenGLProfile OpenGLCompatProfile | ||
71 | disableSpecial AutoPollEvent | ||
72 | let dimensions = GL.Size (fromIntegral w) (fromIntegral h) | ||
73 | result <- openWindow dimensions displayBits windowMode | ||
74 | windowTitle $= case wndTitle of | ||
75 | Nothing -> "Spear Game Framework" | ||
76 | Just title -> title | ||
77 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) | ||
78 | windowSizeCallback $= onResize | ||
79 | windowCloseCallback $= (onWindowClose closeRequest) | ||
80 | onResize (Size (fromIntegral w) (fromIntegral h)) | ||
81 | return $ SpearWindow closeRequest | ||
82 | |||
83 | glfwInit :: Game s () | ||
84 | glfwInit = do | ||
85 | result <- gameIO GLFW.initialize | ||
86 | case result of | ||
87 | False -> gameError "GLFW.initialize failed" | ||
88 | True -> return () | ||
89 | |||
90 | -- | Return true if the application should continue running, false otherwise. | ||
91 | type Update s = Float -> Game s (Bool) | ||
92 | |||
93 | -- | Run the application's main loop. | ||
94 | loop :: SpearWindow -> Update s -> Game s () | ||
95 | loop wnd update = do | ||
96 | gs <- getGameState | ||
97 | flip runSubGame gs $ do | ||
98 | timer <- gameIO $ start newTimer | ||
99 | run (closeRequest wnd) timer update | ||
100 | return () | ||
101 | |||
102 | run :: CloseRequested -> Timer -> Update s -> Game s () | ||
103 | run closeRequest timer update = do | ||
104 | timer' <- gameIO $ tick timer | ||
105 | continue <- update $ getDelta timer' | ||
106 | close <- gameIO $ getRequest closeRequest | ||
107 | when (continue && (not close)) $ run closeRequest timer' update | ||
108 | |||
109 | -- | Run the application's main loop with a limit on the frame rate. | ||
110 | loopCapped :: SpearWindow -> Int -> Update s -> Game s () | ||
111 | loopCapped wnd maxFPS update = do | ||
112 | gs <- getGameState | ||
113 | flip runSubGame gs $ do | ||
114 | let ddt = 1.0 / (fromIntegral maxFPS) | ||
115 | closeReq = closeRequest wnd | ||
116 | frameTimer <- gameIO $ start newTimer | ||
117 | controlTimer <- gameIO $ start newTimer | ||
118 | runCapped closeReq ddt frameTimer controlTimer update | ||
119 | return () | ||
120 | |||
121 | runCapped :: CloseRequested -> Float -> Timer -> Timer -> Update s -> Game s () | ||
122 | runCapped closeRequest ddt frameTimer controlTimer update = do | ||
123 | controlTimer' <- gameIO $ tick controlTimer | ||
124 | frameTimer' <- gameIO $ tick frameTimer | ||
125 | continue <- update $ getDelta frameTimer' | ||
126 | close <- gameIO $ getRequest closeRequest | ||
127 | controlTimer'' <- gameIO $ tick controlTimer' | ||
128 | let dt = getDelta controlTimer'' | ||
129 | when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) | ||
130 | when (continue && (not close)) $ | ||
131 | runCapped closeRequest ddt frameTimer' controlTimer'' update | ||
132 | |||
133 | getRequest :: MVar Bool -> IO Bool | ||
134 | getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of | ||
135 | Nothing -> False | ||
136 | Just x -> x | ||
137 | |||
138 | onWindowClose :: MVar Bool -> WindowCloseCallback | ||
139 | onWindowClose closeRequest = putMVar closeRequest True >> return False | ||
diff --git a/Spear/App/Input.hs b/Spear/App/Input.hs deleted file mode 100644 index 3a4fc99..0000000 --- a/Spear/App/Input.hs +++ /dev/null | |||
@@ -1,265 +0,0 @@ | |||
1 | module Spear.App.Input | ||
2 | ( | ||
3 | -- * Data types | ||
4 | Key(..) | ||
5 | , MouseButton(..) | ||
6 | , MouseProp(..) | ||
7 | , Keyboard | ||
8 | , Mouse(..) | ||
9 | , Input(..) | ||
10 | , ButtonDelay | ||
11 | , DelayedMouse | ||
12 | -- * Input state querying | ||
13 | , newKeyboard | ||
14 | , getKeyboard | ||
15 | , newMouse | ||
16 | , getMouse | ||
17 | , newInput | ||
18 | , getInput | ||
19 | , pollInput | ||
20 | -- * Toggled input | ||
21 | , toggledMouse | ||
22 | , toggledKeyboard | ||
23 | -- * Delayed input | ||
24 | , newDM | ||
25 | , updateDM | ||
26 | , delayedMouse | ||
27 | -- * Input modifiers | ||
28 | , setMousePosition | ||
29 | , setMouseWheel | ||
30 | ) | ||
31 | where | ||
32 | |||
33 | import Data.Char (ord) | ||
34 | import qualified Data.Vector.Unboxed as V | ||
35 | import qualified Graphics.UI.GLFW as GLFW | ||
36 | import Graphics.Rendering.OpenGL.GL.CoordTrans | ||
37 | import Graphics.Rendering.OpenGL.GL.StateVar | ||
38 | |||
39 | data Key | ||
40 | = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H | ||
41 | | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P | ||
42 | | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X | ||
43 | | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5 | ||
44 | | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3 | ||
45 | | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 | ||
46 | | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN | ||
47 | | KEY_LEFT | KEY_RIGHT | ||
48 | deriving (Enum, Bounded) | ||
49 | |||
50 | type Keyboard = Key -> Bool | ||
51 | |||
52 | data MouseButton = LMB | RMB | MMB | ||
53 | deriving (Enum, Bounded) | ||
54 | |||
55 | data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta | ||
56 | deriving Enum | ||
57 | |||
58 | data Mouse = Mouse | ||
59 | { button :: MouseButton -> Bool | ||
60 | , property :: MouseProp -> Float | ||
61 | } | ||
62 | |||
63 | data Input = Input | ||
64 | { keyboard :: Keyboard | ||
65 | , mouse :: Mouse | ||
66 | } | ||
67 | |||
68 | -- | Return a new dummy keyboard. | ||
69 | -- | ||
70 | -- This function should be called to get an initial keyboard. | ||
71 | -- | ||
72 | -- The returned keyboard has all of its keys unpressed. | ||
73 | -- | ||
74 | -- For further keyboard updates, see 'getKeyboard'. | ||
75 | newKeyboard :: Keyboard | ||
76 | newKeyboard = const False | ||
77 | |||
78 | -- | Get the keyboard. | ||
79 | getKeyboard :: IO Keyboard | ||
80 | getKeyboard = | ||
81 | let keyboard' :: V.Vector Bool -> Keyboard | ||
82 | keyboard' keystate key = keystate V.! fromEnum key | ||
83 | keys = fmap toEnum [0..fromEnum (maxBound :: Key)] | ||
84 | in | ||
85 | (fmap (V.fromList . fmap ((==) GLFW.Press)) . mapM GLFW.getKey . fmap toGLFWkey $ keys) | ||
86 | >>= return . keyboard' | ||
87 | |||
88 | -- | Return a new dummy mouse. | ||
89 | -- | ||
90 | -- This function should be called to get an initial mouse. | ||
91 | -- | ||
92 | -- The returned mouse has all keys unpressed, position set to (0,0) and 0 deta values. | ||
93 | -- | ||
94 | -- For further mouse updates, see 'getMouse'. | ||
95 | newMouse :: Mouse | ||
96 | newMouse = Mouse (const False) (const 0) | ||
97 | |||
98 | -- | Get the mouse. | ||
99 | -- | ||
100 | -- The previous mouse state is required to compute position deltas. | ||
101 | getMouse :: Mouse -> IO Mouse | ||
102 | getMouse oldMouse = | ||
103 | let getButton :: V.Vector Bool -> MouseButton -> Bool | ||
104 | getButton mousestate button = mousestate V.! fromEnum button | ||
105 | |||
106 | getProp :: V.Vector Float -> MouseProp -> Float | ||
107 | getProp props prop = props V.! fromEnum prop | ||
108 | |||
109 | props xpos ypos wheel = V.fromList | ||
110 | [ xpos | ||
111 | , ypos | ||
112 | , xpos - property oldMouse MouseX | ||
113 | , ypos - property oldMouse MouseY | ||
114 | , wheel | ||
115 | , wheel - property oldMouse Wheel | ||
116 | ] | ||
117 | |||
118 | getButtonState = | ||
119 | fmap (V.fromList . fmap ((==) GLFW.Press)) . | ||
120 | mapM GLFW.getMouseButton . | ||
121 | fmap toGLFWbutton $ buttons | ||
122 | |||
123 | buttons = fmap toEnum [0..fromEnum (maxBound :: MouseButton)] | ||
124 | in do | ||
125 | Position xpos ypos <- get GLFW.mousePos | ||
126 | wheel <- get GLFW.mouseWheel | ||
127 | buttonState <- getButtonState | ||
128 | return $ Mouse | ||
129 | { button = getButton buttonState | ||
130 | , property = getProp $ props (fromIntegral xpos) (fromIntegral ypos) (fromIntegral wheel) | ||
131 | } | ||
132 | |||
133 | -- | Return a new dummy input. | ||
134 | newInput :: Input | ||
135 | newInput = Input newKeyboard newMouse | ||
136 | |||
137 | -- | Get input devices. | ||
138 | getInput :: Input -> IO Input | ||
139 | getInput (Input _ oldMouse) = do | ||
140 | keyboard <- getKeyboard | ||
141 | mouse <- getMouse oldMouse | ||
142 | return $ Input keyboard mouse | ||
143 | |||
144 | -- | Poll input devices. | ||
145 | pollInput :: IO () | ||
146 | pollInput = GLFW.pollEvents | ||
147 | |||
148 | -- | Return a mouse that reacts to button toggles. | ||
149 | toggledMouse :: Mouse -- ^ Previous mouse state. | ||
150 | -> Mouse -- ^ Current mouse state. | ||
151 | -> Mouse -- ^ Toggled mouse. | ||
152 | |||
153 | toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) } | ||
154 | |||
155 | -- | Return a keyboard that reacts to key toggles. | ||
156 | toggledKeyboard :: Keyboard -- ^ Previous keyboard state. | ||
157 | -> Keyboard -- ^ Current keyboard state. | ||
158 | -> Keyboard -- ^ Toggled keyboard. | ||
159 | |||
160 | toggledKeyboard prev cur key = cur key && not (prev key) | ||
161 | |||
162 | -- | Delay configuration for each mouse button. | ||
163 | type ButtonDelay = MouseButton -> Float | ||
164 | |||
165 | |||
166 | -- | Accumulated delays for each mouse button. | ||
167 | data DelayedMouse = DelayedMouse | ||
168 | { delayedMouse :: Mouse | ||
169 | , delay :: ButtonDelay | ||
170 | , accum :: V.Vector Float | ||
171 | } | ||
172 | |||
173 | newDM :: ButtonDelay -- ^ Delay configuration for each button. | ||
174 | -> DelayedMouse | ||
175 | newDM delay = DelayedMouse newMouse delay $ | ||
176 | V.replicate (fromEnum (maxBound :: MouseButton)) 0 | ||
177 | |||
178 | updateDM :: DelayedMouse -- ^ Current mouse state. | ||
179 | -> Float -- ^ Time elapsed since last udpate. | ||
180 | -> DelayedMouse | ||
181 | |||
182 | updateDM (DelayedMouse mouse delay accum) dt = | ||
183 | let | ||
184 | time b = dt + accum' V.! fromEnum b | ||
185 | active b = time b >= delay b | ||
186 | button' b = active b && button mouse b | ||
187 | accum' = accum V.// fmap newDelay [0 .. fromEnum (maxBound :: MouseButton)] | ||
188 | newDelay x = let b = toEnum x | ||
189 | in (x, if button' b then 0 else time b) | ||
190 | in | ||
191 | DelayedMouse mouse { button = button' } delay accum' | ||
192 | |||
193 | -- | Set the mouse position. | ||
194 | setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse | ||
195 | setMousePosition (x,y) mouse = do | ||
196 | GLFW.mousePos $= Position (fromIntegral x) (fromIntegral y) | ||
197 | getMouse mouse | ||
198 | |||
199 | -- | Set the mouse wheel. | ||
200 | setMouseWheel :: Integral a => a -> Mouse -> IO Mouse | ||
201 | setMouseWheel w mouse = do | ||
202 | GLFW.mouseWheel $= (fromIntegral w) | ||
203 | getMouse mouse | ||
204 | |||
205 | toGLFWkey :: Key -> Int | ||
206 | toGLFWkey KEY_A = ord 'A' | ||
207 | toGLFWkey KEY_B = ord 'B' | ||
208 | toGLFWkey KEY_C = ord 'C' | ||
209 | toGLFWkey KEY_D = ord 'D' | ||
210 | toGLFWkey KEY_E = ord 'E' | ||
211 | toGLFWkey KEY_F = ord 'F' | ||
212 | toGLFWkey KEY_G = ord 'G' | ||
213 | toGLFWkey KEY_H = ord 'H' | ||
214 | toGLFWkey KEY_I = ord 'I' | ||
215 | toGLFWkey KEY_J = ord 'J' | ||
216 | toGLFWkey KEY_K = ord 'K' | ||
217 | toGLFWkey KEY_L = ord 'L' | ||
218 | toGLFWkey KEY_M = ord 'M' | ||
219 | toGLFWkey KEY_N = ord 'N' | ||
220 | toGLFWkey KEY_O = ord 'O' | ||
221 | toGLFWkey KEY_P = ord 'P' | ||
222 | toGLFWkey KEY_Q = ord 'Q' | ||
223 | toGLFWkey KEY_R = ord 'R' | ||
224 | toGLFWkey KEY_S = ord 'S' | ||
225 | toGLFWkey KEY_T = ord 'T' | ||
226 | toGLFWkey KEY_U = ord 'U' | ||
227 | toGLFWkey KEY_V = ord 'V' | ||
228 | toGLFWkey KEY_W = ord 'W' | ||
229 | toGLFWkey KEY_X = ord 'X' | ||
230 | toGLFWkey KEY_Y = ord 'Y' | ||
231 | toGLFWkey KEY_Z = ord 'Z' | ||
232 | toGLFWkey KEY_0 = ord '0' | ||
233 | toGLFWkey KEY_1 = ord '1' | ||
234 | toGLFWkey KEY_2 = ord '2' | ||
235 | toGLFWkey KEY_3 = ord '3' | ||
236 | toGLFWkey KEY_4 = ord '4' | ||
237 | toGLFWkey KEY_5 = ord '5' | ||
238 | toGLFWkey KEY_6 = ord '6' | ||
239 | toGLFWkey KEY_7 = ord '7' | ||
240 | toGLFWkey KEY_8 = ord '8' | ||
241 | toGLFWkey KEY_9 = ord '9' | ||
242 | toGLFWkey KEY_F1 = fromEnum GLFW.F1 | ||
243 | toGLFWkey KEY_F2 = fromEnum GLFW.F2 | ||
244 | toGLFWkey KEY_F3 = fromEnum GLFW.F3 | ||
245 | toGLFWkey KEY_F4 = fromEnum GLFW.F4 | ||
246 | toGLFWkey KEY_F5 = fromEnum GLFW.F5 | ||
247 | toGLFWkey KEY_F6 = fromEnum GLFW.F6 | ||
248 | toGLFWkey KEY_F7 = fromEnum GLFW.F7 | ||
249 | toGLFWkey KEY_F8 = fromEnum GLFW.F8 | ||
250 | toGLFWkey KEY_F9 = fromEnum GLFW.F9 | ||
251 | toGLFWkey KEY_F10 = fromEnum GLFW.F10 | ||
252 | toGLFWkey KEY_F11 = fromEnum GLFW.F11 | ||
253 | toGLFWkey KEY_F12 = fromEnum GLFW.F12 | ||
254 | toGLFWkey KEY_ESC = fromEnum GLFW.ESC | ||
255 | toGLFWkey KEY_SPACE = ord ' ' | ||
256 | toGLFWkey KEY_UP = fromEnum GLFW.UP | ||
257 | toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN | ||
258 | toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT | ||
259 | toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT | ||
260 | |||
261 | |||
262 | toGLFWbutton :: MouseButton -> GLFW.MouseButton | ||
263 | toGLFWbutton LMB = GLFW.ButtonLeft | ||
264 | toGLFWbutton RMB = GLFW.ButtonRight | ||
265 | toGLFWbutton MMB = GLFW.ButtonMiddle | ||
diff --git a/Spear/Game.hs b/Spear/Game.hs index 8d4d8bb..44cb13c 100644 --- a/Spear/Game.hs +++ b/Spear/Game.hs | |||
@@ -17,6 +17,7 @@ module Spear.Game | |||
17 | , catchGameErrorFinally | 17 | , catchGameErrorFinally |
18 | -- * Running and IO | 18 | -- * Running and IO |
19 | , runGame | 19 | , runGame |
20 | , runGame' | ||
20 | , runSubGame | 21 | , runSubGame |
21 | , runSubGame' | 22 | , runSubGame' |
22 | , evalSubGame | 23 | , evalSubGame |
@@ -83,6 +84,12 @@ catchGameErrorFinally game finally = catchError game $ \err -> finally >> gameEr | |||
83 | runGame :: Game s a -> s -> IO (Either String (a,s)) | 84 | runGame :: Game s a -> s -> IO (Either String (a,s)) |
84 | runGame game state = runErrorT . R.runResourceT . runStateT game $ state | 85 | runGame game state = runErrorT . R.runResourceT . runStateT game $ state |
85 | 86 | ||
87 | -- | Run the given game and discard its state. | ||
88 | runGame' :: Game s a -> s -> IO (Either String a) | ||
89 | runGame' g s = runGame g s >>= \result -> return $ case result of | ||
90 | Right (a,s) -> Right a | ||
91 | Left err -> Left err | ||
92 | |||
86 | -- | Fully run the given sub game, unrolling the entire monad stack. | 93 | -- | Fully run the given sub game, unrolling the entire monad stack. |
87 | runSubGame :: Game s a -> s -> Game t (a,s) | 94 | runSubGame :: Game s a -> s -> Game t (a,s) |
88 | runSubGame game state = gameIO (runGame game state) >>= \result -> case result of | 95 | runSubGame game state = gameIO (runGame game state) >>= \result -> case result of |
diff --git a/Spear/Math/AABB.hs b/Spear/Math/AABB.hs index 068a619..de3b1a4 100644 --- a/Spear/Math/AABB.hs +++ b/Spear/Math/AABB.hs | |||
@@ -14,10 +14,10 @@ import Spear.Math.Vector | |||
14 | import Data.List (foldl') | 14 | import Data.List (foldl') |
15 | 15 | ||
16 | -- | An axis-aligned bounding box in 2D space. | 16 | -- | An axis-aligned bounding box in 2D space. |
17 | data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 | 17 | data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 deriving Show |
18 | 18 | ||
19 | -- | An axis-aligned bounding box in 3D space. | 19 | -- | An axis-aligned bounding box in 3D space. |
20 | data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 | 20 | data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 deriving Show |
21 | 21 | ||
22 | -- | Create a AABB from the given points. | 22 | -- | Create a AABB from the given points. |
23 | aabb2 :: [Vector2] -> AABB2 | 23 | aabb2 :: [Vector2] -> AABB2 |
diff --git a/Spear/Math/Entity.hs b/Spear/Math/Entity.hs deleted file mode 100644 index 4d29a95..0000000 --- a/Spear/Math/Entity.hs +++ /dev/null | |||
@@ -1,33 +0,0 @@ | |||
1 | module Spear.Math.Entity | ||
2 | ( | ||
3 | Entity(..) | ||
4 | ) | ||
5 | where | ||
6 | |||
7 | |||
8 | import qualified Spear.Math.Matrix3 as M | ||
9 | import qualified Spear.Math.Spatial2 as S | ||
10 | import qualified Spear.Math.Vector as V | ||
11 | |||
12 | |||
13 | -- | An entity in 2D space. | ||
14 | newtype Entity = Entity { transform :: M.Matrix3 } | ||
15 | |||
16 | |||
17 | instance S.Spatial2 Entity where | ||
18 | move v ent = ent { transform = M.translv v * transform ent } | ||
19 | moveFwd f ent = ent { transform = M.translv (V.scale f $ S.fwd ent) * transform ent } | ||
20 | moveBack f ent = ent { transform = M.translv (V.scale (-f) $ S.fwd ent) * transform ent } | ||
21 | strafeLeft f ent = ent { transform = M.translv (V.scale (-f) $ S.right ent) * transform ent } | ||
22 | strafeRight f ent = ent { transform = M.translv (V.scale f $ S.right ent) * transform ent } | ||
23 | rotate a ent = ent { transform = transform ent * M.rot a } | ||
24 | setRotation a ent = | ||
25 | let t = transform ent | ||
26 | in ent { transform = M.translation t * M.rot a } | ||
27 | pos = M.position . transform | ||
28 | fwd = M.forward . transform | ||
29 | up = M.up . transform | ||
30 | right = M.right . transform | ||
31 | transform (Entity t) = t | ||
32 | setTransform t (Entity _) = Entity t | ||
33 | setPos pos (Entity t) = Entity $ M.transform (M.right t) (M.forward t) pos | ||
diff --git a/Spear/Math/MatrixUtils.hs b/Spear/Math/MatrixUtils.hs index 24d9778..567bee1 100644 --- a/Spear/Math/MatrixUtils.hs +++ b/Spear/Math/MatrixUtils.hs | |||
@@ -11,14 +11,12 @@ module Spear.Math.MatrixUtils | |||
11 | ) | 11 | ) |
12 | where | 12 | where |
13 | 13 | ||
14 | |||
15 | import Spear.Math.Camera as Cam | 14 | import Spear.Math.Camera as Cam |
16 | import Spear.Math.Matrix3 as M3 | 15 | import Spear.Math.Matrix3 as M3 |
17 | import Spear.Math.Matrix4 as M4 | 16 | import Spear.Math.Matrix4 as M4 |
18 | import Spear.Math.Spatial3 as S | 17 | import Spear.Math.Spatial3 as S |
19 | import Spear.Math.Vector as V | 18 | import Spear.Math.Vector as V |
20 | 19 | ||
21 | |||
22 | -- | Compute the normal matrix of the given matrix. | 20 | -- | Compute the normal matrix of the given matrix. |
23 | fastNormalMatrix :: Matrix4 -> Matrix3 | 21 | fastNormalMatrix :: Matrix4 -> Matrix3 |
24 | fastNormalMatrix m = | 22 | fastNormalMatrix m = |
@@ -28,7 +26,6 @@ fastNormalMatrix m = | |||
28 | (M4.m01 m') (M4.m11 m') (M4.m21 m') | 26 | (M4.m01 m') (M4.m11 m') (M4.m21 m') |
29 | (M4.m02 m') (M4.m12 m') (M4.m22 m') | 27 | (M4.m02 m') (M4.m12 m') (M4.m22 m') |
30 | 28 | ||
31 | |||
32 | -- | Transform the given point in window coordinates to object coordinates. | 29 | -- | Transform the given point in window coordinates to object coordinates. |
33 | unproject :: Matrix4 -- ^ Inverse projection matrix | 30 | unproject :: Matrix4 -- ^ Inverse projection matrix |
34 | -> Matrix4 -- ^ Inverse modelview matrix. | 31 | -> Matrix4 -- ^ Inverse modelview matrix. |
@@ -48,7 +45,6 @@ unproject projI modelviewI vpx vpy w h x y z = | |||
48 | in | 45 | in |
49 | (modelviewI * projI) `M4.mulp` vec3 xmouse ymouse zmouse | 46 | (modelviewI * projI) `M4.mulp` vec3 xmouse ymouse zmouse |
50 | 47 | ||
51 | |||
52 | -- | Transform the given point in window coordinates to 2d coordinates. | 48 | -- | Transform the given point in window coordinates to 2d coordinates. |
53 | -- | 49 | -- |
54 | -- The line defined by the given point in window space is intersected with | 50 | -- The line defined by the given point in window space is intersected with |
@@ -72,7 +68,6 @@ rpgUnproject projI viewI vpx vpy w h wx wy = | |||
72 | in | 68 | in |
73 | vec2 (x p') (-(z p')) | 69 | vec2 (x p') (-(z p')) |
74 | 70 | ||
75 | |||
76 | -- | Map an object's transform in view space to world space. | 71 | -- | Map an object's transform in view space to world space. |
77 | rpgTransform | 72 | rpgTransform |
78 | :: Float -- ^ The height above the ground | 73 | :: Float -- ^ The height above the ground |
@@ -97,7 +92,6 @@ rpgTransform h a axis pos viewI = | |||
97 | (z r) (z u) (z f) (z t) | 92 | (z r) (z u) (z f) (z t) |
98 | 0 0 0 1 | 93 | 0 0 0 1 |
99 | 94 | ||
100 | |||
101 | -- | Map an object's transform in view space to world space. | 95 | -- | Map an object's transform in view space to world space. |
102 | pltTransform :: Matrix3 -> Matrix4 | 96 | pltTransform :: Matrix3 -> Matrix4 |
103 | pltTransform mat = | 97 | pltTransform mat = |
@@ -111,7 +105,6 @@ pltTransform mat = | |||
111 | (z r) (z u) (z f) (z t) | 105 | (z r) (z u) (z f) (z t) |
112 | 0 0 0 1 | 106 | 0 0 0 1 |
113 | 107 | ||
114 | |||
115 | -- | Map an object's transform in world space to view space. | 108 | -- | Map an object's transform in world space to view space. |
116 | -- | 109 | -- |
117 | -- The XY plane in 2D translates to the X(-Z) plane in 3D. | 110 | -- The XY plane in 2D translates to the X(-Z) plane in 3D. |
@@ -127,7 +120,6 @@ rpgInverse | |||
127 | rpgInverse h a axis pos viewI = | 120 | rpgInverse h a axis pos viewI = |
128 | M4.inverseTransform $ rpgTransform h a axis pos viewI | 121 | M4.inverseTransform $ rpgTransform h a axis pos viewI |
129 | 122 | ||
130 | |||
131 | -- | Map an object's transform in world space to view space. | 123 | -- | Map an object's transform in world space to view space. |
132 | -- | 124 | -- |
133 | -- This function maps an object's transform in 2D to the object's inverse in 3D. | 125 | -- This function maps an object's transform in 2D to the object's inverse in 3D. |
@@ -138,7 +130,6 @@ rpgInverse h a axis pos viewI = | |||
138 | pltInverse :: Matrix3 -> Matrix4 | 130 | pltInverse :: Matrix3 -> Matrix4 |
139 | pltInverse = M4.inverseTransform . pltTransform | 131 | pltInverse = M4.inverseTransform . pltTransform |
140 | 132 | ||
141 | |||
142 | -- | Transform an object from object to clip space coordinates. | 133 | -- | Transform an object from object to clip space coordinates. |
143 | objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 | 134 | objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 |
144 | objToClip cam model p = | 135 | objToClip cam model p = |
diff --git a/Spear/Math/Spatial2.hs b/Spear/Math/Spatial2.hs index b9dde44..b2399f8 100644 --- a/Spear/Math/Spatial2.hs +++ b/Spear/Math/Spatial2.hs | |||
@@ -1,75 +1,151 @@ | |||
1 | module Spear.Math.Spatial2 | 1 | module Spear.Math.Spatial2 |
2 | ( | ||
3 | Spatial2(..) | ||
4 | , Obj2 | ||
5 | , Angle | ||
6 | , Radius | ||
7 | , move | ||
8 | , moveFwd | ||
9 | , moveBack | ||
10 | , moveUp | ||
11 | , moveDown | ||
12 | , moveLeft | ||
13 | , moveRight | ||
14 | , rotate | ||
15 | , setRotation | ||
16 | , pos | ||
17 | , fwd | ||
18 | , up | ||
19 | , right | ||
20 | , transform | ||
21 | , setTransform | ||
22 | , setPos | ||
23 | , lookAt | ||
24 | , Spear.Math.Spatial2.orbit | ||
25 | , obj2FromVectors | ||
26 | , obj2FromTransform | ||
27 | ) | ||
2 | where | 28 | where |
3 | 29 | ||
4 | |||
5 | import Spear.Math.Vector | 30 | import Spear.Math.Vector |
6 | import Spear.Math.Matrix3 as M | 31 | import qualified Spear.Math.Matrix3 as M |
7 | 32 | ||
33 | type Angle = Float | ||
34 | type Radius = Float | ||
8 | 35 | ||
9 | -- | An entity that can be moved around in 2D space. | 36 | -- | An entity that can be moved around in 2D space. |
10 | class Spatial2 s where | 37 | class Spatial2 s where |
11 | 38 | ||
12 | -- | Move the spatial. | 39 | -- | Gets the spatial's Obj2. |
13 | move :: Vector2 -> s -> s | 40 | getObj2 :: s -> Obj2 |
14 | 41 | ||
15 | -- | Move the spatial forwards. | 42 | -- | Set the spatial's Obj2. |
16 | moveFwd :: Float -> s -> s | 43 | setObj2 :: s -> Obj2 -> s |
17 | 44 | ||
18 | -- | Move the spatial backwards. | 45 | -- | Move the spatial. |
19 | moveBack :: Float -> s -> s | 46 | move :: Spatial2 s => Vector2 -> s -> s |
20 | 47 | move v s = let o = getObj2 s in setObj2 s $ o { p = p o + v } | |
21 | -- | Make the spatial strafe left. | 48 | |
22 | strafeLeft :: Float -> s -> s | 49 | -- | Move the spatial forwards. |
23 | 50 | moveFwd :: Spatial2 s => Float -> s -> s | |
24 | -- | Make the spatial Strafe right. | 51 | moveFwd a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale a (fwd o) } |
25 | strafeRight :: Float -> s -> s | 52 | |
26 | 53 | -- | Move the spatial backwards. | |
27 | -- | Rotate the spatial. | 54 | moveBack :: Spatial2 s => Float -> s -> s |
28 | rotate :: Float -> s -> s | 55 | moveBack a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale (-a) (fwd o) } |
29 | 56 | ||
30 | -- | Set the spatial's rotation. | 57 | -- | Move the spatial up. |
31 | setRotation :: Float -> s -> s | 58 | moveUp :: Spatial2 s => Float -> s -> s |
32 | 59 | moveUp a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale a (fwd o) } | |
33 | -- | Get the spatial position. | 60 | |
34 | pos :: s -> Vector2 | 61 | -- | Move the spatial down. |
35 | 62 | moveDown :: Spatial2 s => Float -> s -> s | |
36 | -- | Get the spatial's forward vector. | 63 | moveDown a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale (-a) (fwd o) } |
37 | fwd :: s -> Vector2 | 64 | |
38 | 65 | -- | Make the spatial strafe left. | |
39 | -- | Get the spatial's up vector. | 66 | moveLeft :: Spatial2 s => Float -> s -> s |
40 | up :: s -> Vector2 | 67 | moveLeft a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale (-a) (right o) } |
41 | 68 | ||
42 | -- | Get the spatial's right vector. | 69 | -- | Make the spatial Strafe right. |
43 | right :: s -> Vector2 | 70 | moveRight :: Spatial2 s => Float -> s -> s |
44 | 71 | moveRight a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale a (right o) } | |
45 | -- | Get the spatial's transform. | 72 | |
46 | transform :: s -> Matrix3 | 73 | -- | Rotate the spatial. |
47 | 74 | rotate :: Spatial2 s => Float -> s -> s | |
48 | -- | Set the spatial's transform. | 75 | rotate angle s = let o = getObj2 s in setObj2 s $ o |
49 | setTransform :: Matrix3 -> s -> s | 76 | { r = rotate' angle (r o) |
50 | 77 | , u = rotate' angle (u o) | |
51 | -- | Set the spatial's position. | 78 | } |
52 | setPos :: Vector2 -> s -> s | 79 | |
53 | 80 | -- | Set the spatial's rotation. | |
54 | -- | Make the spatial look at the given point. | 81 | setRotation :: Spatial2 s => Float -> s -> s |
55 | lookAt :: Vector2 -> s -> s | 82 | setRotation angle s = let o = getObj2 s in setObj2 s $ o |
56 | lookAt pt s = | 83 | { r = rotate' angle unitx2 |
57 | let position = pos s | 84 | , u = rotate' angle unity2 |
58 | fwd = normalise $ pt - position | 85 | } |
59 | r = perp fwd | 86 | |
60 | in | 87 | rotate' :: Float -> Vector2 -> Vector2 |
61 | setTransform (M.transform r fwd position) s | 88 | rotate' a' (Vector2 x y) = vec2 (x * cos a) (y * sin a) where a = a'*pi/180 |
62 | 89 | ||
63 | -- | Make the 'Spatial' orbit around the given point | 90 | -- | Get the spatial's position. |
64 | orbit :: Vector2 -- ^ Target point | 91 | pos :: Spatial2 s => s -> Vector2 |
65 | -> Float -- ^ Angle | 92 | pos = p . getObj2 |
66 | -> Float -- ^ Orbit radius | 93 | |
67 | -> s | 94 | -- | Get the spatial's forward vector. |
68 | -> s | 95 | fwd :: Spatial2 s => s -> Vector2 |
69 | 96 | fwd = u . getObj2 | |
70 | orbit pt angle radius s = | 97 | |
71 | let a = angle * pi / 180 | 98 | -- | Get the spatial's up vector. |
72 | px = (x pt) + radius * sin a | 99 | up :: Spatial2 s => s -> Vector2 |
73 | py = (y pt) + radius * cos a | 100 | up = u . getObj2 |
74 | in | 101 | |
75 | setPos (vec2 px py) s | 102 | -- | Get the spatial's right vector. |
103 | right :: Spatial2 s => s -> Vector2 | ||
104 | right = r . getObj2 | ||
105 | |||
106 | -- | Get the spatial's transform. | ||
107 | transform :: Spatial2 s => s -> M.Matrix3 | ||
108 | transform s = let o = getObj2 s in M.transform (r o) (u o) (p o) | ||
109 | |||
110 | -- | Set the spatial's transform. | ||
111 | setTransform :: Spatial2 s => M.Matrix3 -> s -> s | ||
112 | setTransform t s = | ||
113 | let o = Obj2 (M.right t) (M.up t) (M.position t) | ||
114 | in setObj2 s o | ||
115 | |||
116 | -- | Set the spatial's position. | ||
117 | setPos :: Spatial2 s => Vector2 -> s -> s | ||
118 | setPos pos s = setObj2 s $ (getObj2 s) { p = pos } | ||
119 | |||
120 | -- | Make the spatial look at the given point. | ||
121 | lookAt :: Spatial2 s => Vector2 -> s -> s | ||
122 | lookAt pt s = | ||
123 | let position = pos s | ||
124 | fwd = normalise $ pt - position | ||
125 | r = perp fwd | ||
126 | in setTransform (M.transform r fwd position) s | ||
127 | |||
128 | -- | Make the 'Spatial' orbit around the given point | ||
129 | orbit :: Spatial2 s => Vector2 -> Angle -> Radius -> s -> s | ||
130 | orbit pt angle radius s = | ||
131 | let a = angle * pi / 180 | ||
132 | px = (x pt) + radius * sin a | ||
133 | py = (y pt) + radius * cos a | ||
134 | in setPos (vec2 px py) s | ||
135 | |||
136 | -- | An object in 2D space. | ||
137 | data Obj2 = Obj2 | ||
138 | { r :: Vector2 | ||
139 | , u :: Vector2 | ||
140 | , p :: Vector2 | ||
141 | } deriving Show | ||
142 | |||
143 | instance Spatial2 Obj2 where | ||
144 | getObj2 = id | ||
145 | setObj2 _ o' = o' | ||
146 | |||
147 | obj2FromVectors :: Right2 -> Up2 -> Position2 -> Obj2 | ||
148 | obj2FromVectors = Obj2 | ||
149 | |||
150 | obj2FromTransform :: M.Matrix3 -> Obj2 | ||
151 | obj2FromTransform m = Obj2 (M.right m) (M.up m) (M.position m) \ No newline at end of file | ||
diff --git a/Spear/Math/Spatial3.hs b/Spear/Math/Spatial3.hs index c9495eb..896d5ae 100644 --- a/Spear/Math/Spatial3.hs +++ b/Spear/Math/Spatial3.hs | |||
@@ -2,6 +2,24 @@ module Spear.Math.Spatial3 | |||
2 | ( | 2 | ( |
3 | Spatial3(..) | 3 | Spatial3(..) |
4 | , Obj3 | 4 | , Obj3 |
5 | , move | ||
6 | , moveFwd | ||
7 | , moveBack | ||
8 | , moveLeft | ||
9 | , moveRight | ||
10 | , rotate | ||
11 | , pitch | ||
12 | , yaw | ||
13 | , roll | ||
14 | , pos | ||
15 | , fwd | ||
16 | , up | ||
17 | , right | ||
18 | , transform | ||
19 | , setTransform | ||
20 | , setPos | ||
21 | , lookAt | ||
22 | , Spear.Math.Spatial3.orbit | ||
5 | , fromVectors | 23 | , fromVectors |
6 | , fromTransform | 24 | , fromTransform |
7 | ) | 25 | ) |
@@ -13,132 +31,132 @@ import qualified Spear.Math.Matrix4 as M | |||
13 | type Matrix4 = M.Matrix4 | 31 | type Matrix4 = M.Matrix4 |
14 | 32 | ||
15 | class Spatial3 s where | 33 | class Spatial3 s where |
16 | -- | Gets the spatial's internal Obj3. | 34 | |
17 | getObj3 :: s -> Obj3 | 35 | -- | Gets the spatial's Obj3. |
18 | 36 | getObj3 :: s -> Obj3 | |
19 | -- | Set the spatial's internal Obj3. | 37 | |
20 | setObj3 :: s -> Obj3 -> s | 38 | -- | Set the spatial's Obj3. |
21 | 39 | setObj3 :: s -> Obj3 -> s | |
22 | -- | Move the spatial. | 40 | |
23 | move :: Vector3 -> s -> s | 41 | -- | Move the spatial. |
24 | move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } | 42 | move :: Spatial3 s => Vector3 -> s -> s |
25 | 43 | move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } | |
26 | -- | Move the spatial forwards. | 44 | |
27 | moveFwd :: Float -> s -> s | 45 | -- | Move the spatial forwards. |
28 | moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } | 46 | moveFwd :: Spatial3 s => Float -> s -> s |
29 | 47 | moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } | |
30 | -- | Move the spatial backwards. | 48 | |
31 | moveBack :: Float -> s -> s | 49 | -- | Move the spatial backwards. |
32 | moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } | 50 | moveBack :: Spatial3 s => Float -> s -> s |
33 | 51 | moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } | |
34 | -- | Make the spatial strafe left. | 52 | |
35 | strafeLeft :: Float -> s -> s | 53 | -- | Make the spatial strafe left. |
36 | strafeLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } | 54 | moveLeft :: Spatial3 s => Float -> s -> s |
37 | 55 | moveLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } | |
38 | -- | Make the spatial Strafe right. | 56 | |
39 | strafeRight :: Float -> s -> s | 57 | -- | Make the spatial Strafe right. |
40 | strafeRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } | 58 | moveRight :: Spatial3 s => Float -> s -> s |
41 | 59 | moveRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } | |
42 | -- | Rotate the spatial about the given axis. | 60 | |
43 | rotate :: Vector3 -> Float -> s -> s | 61 | -- | Rotate the spatial about the given axis. |
44 | rotate axis a s = | 62 | rotate :: Spatial3 s => Vector3 -> Float -> s -> s |
45 | let t = transform s | 63 | rotate axis a s = |
46 | axis' = M.inverseTransform t `M.muld` axis | 64 | let t = transform s |
47 | in setTransform (t * M.axisAngle axis' a) s | 65 | axis' = M.inverseTransform t `M.muld` axis |
48 | 66 | in setTransform (t * M.axisAngle axis' a) s | |
49 | -- | Rotate the spatial about its local X axis. | 67 | |
50 | pitch :: Float -> s -> s | 68 | -- | Rotate the spatial about its local X axis. |
51 | pitch a s = | 69 | pitch :: Spatial3 s => Float -> s -> s |
52 | let o = getObj3 s | 70 | pitch a s = |
53 | a' = toRAD a | 71 | let o = getObj3 s |
54 | sa = sin a' | 72 | a' = toRAD a |
55 | ca = cos a' | 73 | sa = sin a' |
56 | f' = normalise $ scale ca (f o) + scale sa (u o) | 74 | ca = cos a' |
57 | u' = normalise $ r o `cross` f' | 75 | f' = normalise $ scale ca (f o) + scale sa (u o) |
58 | in setObj3 s $ o { u = u', f = f' } | 76 | u' = normalise $ r o `cross` f' |
59 | 77 | in setObj3 s $ o { u = u', f = f' } | |
60 | -- | Rotate the spatial about its local Y axis. | 78 | |
61 | yaw :: Float -> s -> s | 79 | -- | Rotate the spatial about its local Y axis. |
62 | yaw a s = | 80 | yaw :: Spatial3 s => Float -> s -> s |
63 | let o = getObj3 s | 81 | yaw a s = |
64 | a' = toRAD a | 82 | let o = getObj3 s |
65 | sa = sin a' | 83 | a' = toRAD a |
66 | ca = cos a' | 84 | sa = sin a' |
67 | r' = normalise $ scale ca (r o) + scale sa (f o) | 85 | ca = cos a' |
68 | f' = normalise $ u o `cross` r' | 86 | r' = normalise $ scale ca (r o) + scale sa (f o) |
69 | in setObj3 s $ o { r = r', f = f' } | 87 | f' = normalise $ u o `cross` r' |
70 | 88 | in setObj3 s $ o { r = r', f = f' } | |
71 | -- | Rotate the spatial about its local Z axis. | 89 | |
72 | roll :: Float -> s -> s | 90 | -- | Rotate the spatial about its local Z axis. |
73 | roll a s = | 91 | roll :: Spatial3 s => Float -> s -> s |
74 | let o = getObj3 s | 92 | roll a s = |
75 | a' = toRAD a | 93 | let o = getObj3 s |
76 | sa = sin a' | 94 | a' = toRAD a |
77 | ca = cos a' | 95 | sa = sin a' |
78 | u' = normalise $ scale ca (u o) - scale sa (r o) | 96 | ca = cos a' |
79 | r' = normalise $ f o `cross` u' | 97 | u' = normalise $ scale ca (u o) - scale sa (r o) |
80 | in setObj3 s $ o { r = r', u = u' } | 98 | r' = normalise $ f o `cross` u' |
81 | 99 | in setObj3 s $ o { r = r', u = u' } | |
82 | -- | Get the spatial's position. | 100 | |
83 | pos :: s -> Vector3 | 101 | -- | Get the spatial's position. |
84 | pos = p . getObj3 | 102 | pos :: Spatial3 s => s -> Vector3 |
85 | 103 | pos = p . getObj3 | |
86 | -- | Get the spatial's forward vector. | 104 | |
87 | fwd :: s -> Vector3 | 105 | -- | Get the spatial's forward vector. |
88 | fwd = f . getObj3 | 106 | fwd :: Spatial3 s => s -> Vector3 |
89 | 107 | fwd = f . getObj3 | |
90 | -- | Get the spatial's up vector. | 108 | |
91 | up :: s -> Vector3 | 109 | -- | Get the spatial's up vector. |
92 | up = u . getObj3 | 110 | up :: Spatial3 s => s -> Vector3 |
93 | 111 | up = u . getObj3 | |
94 | -- | Get the spatial's right vector. | 112 | |
95 | right :: s -> Vector3 | 113 | -- | Get the spatial's right vector. |
96 | right = r . getObj3 | 114 | right :: Spatial3 s => s -> Vector3 |
97 | 115 | right = r . getObj3 | |
98 | -- | Get the spatial's transform. | 116 | |
99 | transform :: s -> Matrix4 | 117 | -- | Get the spatial's transform. |
100 | transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) | 118 | transform :: Spatial3 s => s -> Matrix4 |
101 | 119 | transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) | |
102 | -- | Set the spatial's transform. | 120 | |
103 | setTransform :: Matrix4 -> s -> s | 121 | -- | Set the spatial's transform. |
104 | setTransform t s = | 122 | setTransform :: Spatial3 s => Matrix4 -> s -> s |
105 | let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) | 123 | setTransform t s = |
106 | in setObj3 s o | 124 | let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) |
107 | 125 | in setObj3 s o | |
108 | -- | Set the spatial's position. | 126 | |
109 | setPos :: Vector3 -> s -> s | 127 | -- | Set the spatial's position. |
110 | setPos pos s = setObj3 s $ (getObj3 s) { p = pos } | 128 | setPos :: Spatial3 s => Vector3 -> s -> s |
111 | 129 | setPos pos s = setObj3 s $ (getObj3 s) { p = pos } | |
112 | -- | Make the spatial look at the given point. | 130 | |
113 | lookAt :: Vector3 -> s -> s | 131 | -- | Make the spatial look at the given point. |
114 | lookAt pt s = | 132 | lookAt :: Spatial3 s => Vector3 -> s -> s |
115 | let position = pos s | 133 | lookAt pt s = |
116 | fwd = normalise $ pt - position | 134 | let position = pos s |
117 | r = fwd `cross` unity3 | 135 | fwd = normalise $ pt - position |
118 | u = r `cross` fwd | 136 | r = fwd `cross` unity3 |
119 | in | 137 | u = r `cross` fwd |
120 | setTransform (M.transform r u (-fwd) position) s | 138 | in setTransform (M.transform r u (-fwd) position) s |
121 | 139 | ||
122 | -- | Make the spatial orbit around the given point | 140 | -- | Make the spatial orbit around the given point |
123 | orbit :: Vector3 -- ^ Target point | 141 | orbit :: Spatial3 s |
124 | -> Float -- ^ Horizontal angle | 142 | => Vector3 -- ^ Target point |
125 | -> Float -- ^ Vertical angle | 143 | -> Float -- ^ Horizontal angle |
126 | -> Float -- ^ Orbit radius. | 144 | -> Float -- ^ Vertical angle |
127 | -> s | 145 | -> Float -- ^ Orbit radius. |
128 | -> s | 146 | -> s |
129 | 147 | -> s | |
130 | orbit pt anglex angley radius s = | 148 | |
131 | let ax = anglex * pi / 180 | 149 | orbit pt anglex angley radius s = |
132 | ay = angley * pi / 180 | 150 | let ax = anglex * pi / 180 |
133 | sx = sin ax | 151 | ay = angley * pi / 180 |
134 | sy = sin ay | 152 | sx = sin ax |
135 | cx = cos ax | 153 | sy = sin ay |
136 | cy = cos ay | 154 | cx = cos ax |
137 | px = (x pt) + radius*cy*sx | 155 | cy = cos ay |
138 | py = (y pt) + radius*sy | 156 | px = (x pt) + radius*cy*sx |
139 | pz = (z pt) + radius*cx*cy | 157 | py = (y pt) + radius*sy |
140 | in | 158 | pz = (z pt) + radius*cx*cy |
141 | setPos (vec3 px py pz) s | 159 | in setPos (vec3 px py pz) s |
142 | 160 | ||
143 | -- | An object in 3D space. | 161 | -- | An object in 3D space. |
144 | data Obj3 = Obj3 | 162 | data Obj3 = Obj3 |
diff --git a/Spear/Math/Vector/Vector2.hs b/Spear/Math/Vector/Vector2.hs index 0b29ec4..dfb4fb9 100644 --- a/Spear/Math/Vector/Vector2.hs +++ b/Spear/Math/Vector/Vector2.hs | |||
@@ -1,6 +1,9 @@ | |||
1 | module Spear.Math.Vector.Vector2 | 1 | module Spear.Math.Vector.Vector2 |
2 | ( | 2 | ( |
3 | Vector2 | 3 | Vector2(..) |
4 | , Right2 | ||
5 | , Up2 | ||
6 | , Position2 | ||
4 | -- * Construction | 7 | -- * Construction |
5 | , unitx2 | 8 | , unitx2 |
6 | , unity2 | 9 | , unity2 |
@@ -11,13 +14,14 @@ module Spear.Math.Vector.Vector2 | |||
11 | ) | 14 | ) |
12 | where | 15 | where |
13 | 16 | ||
14 | |||
15 | import Spear.Math.Vector.Class | 17 | import Spear.Math.Vector.Class |
16 | 18 | ||
17 | |||
18 | import Foreign.C.Types (CFloat) | 19 | import Foreign.C.Types (CFloat) |
19 | import Foreign.Storable | 20 | import Foreign.Storable |
20 | 21 | ||
22 | type Right2 = Vector2 | ||
23 | type Up2 = Vector2 | ||
24 | type Position2 = Vector2 | ||
21 | 25 | ||
22 | -- | Represents a vector in 2D. | 26 | -- | Represents a vector in 2D. |
23 | data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) | 27 | data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) |
@@ -30,13 +34,13 @@ instance Num Vector2 where | |||
30 | abs (Vector2 ax ay) = Vector2 (abs ax) (abs ay) | 34 | abs (Vector2 ax ay) = Vector2 (abs ax) (abs ay) |
31 | signum (Vector2 ax ay) = Vector2 (signum ax) (signum ay) | 35 | signum (Vector2 ax ay) = Vector2 (signum ax) (signum ay) |
32 | fromInteger i = Vector2 i' i' where i' = fromInteger i | 36 | fromInteger i = Vector2 i' i' where i' = fromInteger i |
33 | 37 | ||
34 | 38 | ||
35 | instance Fractional Vector2 where | 39 | instance Fractional Vector2 where |
36 | Vector2 ax ay / Vector2 bx by = Vector2 (ax / bx) (ay / by) | 40 | Vector2 ax ay / Vector2 bx by = Vector2 (ax / bx) (ay / by) |
37 | fromRational r = Vector2 r' r' where r' = fromRational r | 41 | fromRational r = Vector2 r' r' where r' = fromRational r |
38 | 42 | ||
39 | 43 | ||
40 | instance Ord Vector2 where | 44 | instance Ord Vector2 where |
41 | Vector2 ax ay <= Vector2 bx by = (ax <= bx) || (ax == bx && ay <= by) | 45 | Vector2 ax ay <= Vector2 bx by = (ax <= bx) || (ax == bx && ay <= by) |
42 | Vector2 ax ay >= Vector2 bx by = (ax >= bx) || (ax == bx && ay >= by) | 46 | Vector2 ax ay >= Vector2 bx by = (ax >= bx) || (ax == bx && ay >= by) |
@@ -89,18 +93,18 @@ sizeFloat = sizeOf (undefined :: CFloat) | |||
89 | instance Storable Vector2 where | 93 | instance Storable Vector2 where |
90 | sizeOf _ = 2*sizeFloat | 94 | sizeOf _ = 2*sizeFloat |
91 | alignment _ = alignment (undefined :: CFloat) | 95 | alignment _ = alignment (undefined :: CFloat) |
92 | 96 | ||
93 | peek ptr = do | 97 | peek ptr = do |
94 | ax <- peekByteOff ptr 0 | 98 | ax <- peekByteOff ptr 0 |
95 | ay <- peekByteOff ptr $ sizeFloat | 99 | ay <- peekByteOff ptr $ sizeFloat |
96 | return (Vector2 ax ay) | 100 | return (Vector2 ax ay) |
97 | 101 | ||
98 | poke ptr (Vector2 ax ay) = do | 102 | poke ptr (Vector2 ax ay) = do |
99 | pokeByteOff ptr 0 ax | 103 | pokeByteOff ptr 0 ax |
100 | pokeByteOff ptr sizeFloat ay | 104 | pokeByteOff ptr sizeFloat ay |
101 | 105 | ||
102 | 106 | ||
103 | -- | Get the vector's x coordinate. | 107 | -- | Get the vector's x coordinate. |
104 | 108 | ||
105 | 109 | ||
106 | 110 | ||
@@ -122,9 +126,9 @@ vec2 ax ay = Vector2 ax ay | |||
122 | 126 | ||
123 | 127 | ||
124 | -- | Compute a vector perpendicular to the given one, satisfying: | 128 | -- | Compute a vector perpendicular to the given one, satisfying: |
125 | -- | 129 | -- |
126 | -- perp (Vector2 0 1) = Vector2 1 0 | 130 | -- perp (Vector2 0 1) = Vector2 1 0 |
127 | -- | 131 | -- |
128 | -- perp (Vector2 1 0) = Vector2 0 (-1) | 132 | -- perp (Vector2 1 0) = Vector2 0 (-1) |
129 | perp :: Vector2 -> Vector2 | 133 | perp :: Vector2 -> Vector2 |
130 | perp (Vector2 x y) = Vector2 y (-x) | 134 | perp (Vector2 x y) = Vector2 y (-x) |
diff --git a/Spear/Math/Vector/Vector3.hs b/Spear/Math/Vector/Vector3.hs index 70bd299..429df0f 100644 --- a/Spear/Math/Vector/Vector3.hs +++ b/Spear/Math/Vector/Vector3.hs | |||
@@ -1,6 +1,6 @@ | |||
1 | module Spear.Math.Vector.Vector3 | 1 | module Spear.Math.Vector.Vector3 |
2 | ( | 2 | ( |
3 | Vector3 | 3 | Vector3(..) |
4 | , Right3 | 4 | , Right3 |
5 | , Up3 | 5 | , Up3 |
6 | , Forward3 | 6 | , Forward3 |
diff --git a/Spear/Math/Vector/Vector4.hs b/Spear/Math/Vector/Vector4.hs index 3b5ed95..4314b51 100644 --- a/Spear/Math/Vector/Vector4.hs +++ b/Spear/Math/Vector/Vector4.hs | |||
@@ -1,6 +1,6 @@ | |||
1 | module Spear.Math.Vector.Vector4 | 1 | module Spear.Math.Vector.Vector4 |
2 | ( | 2 | ( |
3 | Vector4 | 3 | Vector4(..) |
4 | -- * Construction | 4 | -- * Construction |
5 | , unitx4 | 5 | , unitx4 |
6 | , unity4 | 6 | , unity4 |
@@ -34,32 +34,32 @@ instance Num Vector4 where | |||
34 | abs (Vector4 ax ay az aw) = Vector4 (abs ax) (abs ay) (abs az) (abs aw) | 34 | abs (Vector4 ax ay az aw) = Vector4 (abs ax) (abs ay) (abs az) (abs aw) |
35 | signum (Vector4 ax ay az aw) = Vector4 (signum ax) (signum ay) (signum az) (signum aw) | 35 | signum (Vector4 ax ay az aw) = Vector4 (signum ax) (signum ay) (signum az) (signum aw) |
36 | fromInteger i = Vector4 i' i' i' i' where i' = fromInteger i | 36 | fromInteger i = Vector4 i' i' i' i' where i' = fromInteger i |
37 | 37 | ||
38 | 38 | ||
39 | instance Fractional Vector4 where | 39 | instance Fractional Vector4 where |
40 | Vector4 ax ay az aw / Vector4 bx by bz bw = Vector4 (ax / bx) (ay / by) (az / bz) (aw / bw) | 40 | Vector4 ax ay az aw / Vector4 bx by bz bw = Vector4 (ax / bx) (ay / by) (az / bz) (aw / bw) |
41 | fromRational r = Vector4 r' r' r' r' where r' = fromRational r | 41 | fromRational r = Vector4 r' r' r' r' where r' = fromRational r |
42 | 42 | ||
43 | 43 | ||
44 | instance Ord Vector4 where | 44 | instance Ord Vector4 where |
45 | Vector4 ax ay az aw <= Vector4 bx by bz bw | 45 | Vector4 ax ay az aw <= Vector4 bx by bz bw |
46 | = (ax <= bx) | 46 | = (ax <= bx) |
47 | || (az == bx && ay <= by) | 47 | || (az == bx && ay <= by) |
48 | || (ax == bx && ay == by && az <= bz) | 48 | || (ax == bx && ay == by && az <= bz) |
49 | || (ax == bx && ay == by && az == bz && aw <= bw) | 49 | || (ax == bx && ay == by && az == bz && aw <= bw) |
50 | 50 | ||
51 | Vector4 ax ay az aw >= Vector4 bx by bz bw | 51 | Vector4 ax ay az aw >= Vector4 bx by bz bw |
52 | = (ax >= bx) | 52 | = (ax >= bx) |
53 | || (ax == bx && ay >= by) | 53 | || (ax == bx && ay >= by) |
54 | || (ax == bx && ay == by && az >= bz) | 54 | || (ax == bx && ay == by && az >= bz) |
55 | || (ax == bx && ay == by && az == bz && aw >= bw) | 55 | || (ax == bx && ay == by && az == bz && aw >= bw) |
56 | 56 | ||
57 | Vector4 ax ay az aw < Vector4 bx by bz bw | 57 | Vector4 ax ay az aw < Vector4 bx by bz bw |
58 | = (ax < bx) | 58 | = (ax < bx) |
59 | || (az == bx && ay < by) | 59 | || (az == bx && ay < by) |
60 | || (ax == bx && ay == by && az < bz) | 60 | || (ax == bx && ay == by && az < bz) |
61 | || (ax == bx && ay == by && az == bz && aw < bw) | 61 | || (ax == bx && ay == by && az == bz && aw < bw) |
62 | 62 | ||
63 | Vector4 ax ay az aw > Vector4 bx by bz bw | 63 | Vector4 ax ay az aw > Vector4 bx by bz bw |
64 | = (ax > bx) | 64 | = (ax > bx) |
65 | || (ax == bx && ay > by) | 65 | || (ax == bx && ay > by) |
@@ -88,29 +88,29 @@ instance VectorClass Vector4 where | |||
88 | 88 | ||
89 | {-# INLINABLE w #-} | 89 | {-# INLINABLE w #-} |
90 | w (Vector4 _ _ _ aw) = aw | 90 | w (Vector4 _ _ _ aw) = aw |
91 | 91 | ||
92 | {-# INLINABLE (!) #-} | 92 | {-# INLINABLE (!) #-} |
93 | (Vector4 ax _ _ _) ! 0 = ax | 93 | (Vector4 ax _ _ _) ! 0 = ax |
94 | (Vector4 _ ay _ _) ! 1 = ay | 94 | (Vector4 _ ay _ _) ! 1 = ay |
95 | (Vector4 _ _ az _) ! 2 = az | 95 | (Vector4 _ _ az _) ! 2 = az |
96 | (Vector4 _ _ _ aw) ! 3 = aw | 96 | (Vector4 _ _ _ aw) ! 3 = aw |
97 | _ ! _ = 0 | 97 | _ ! _ = 0 |
98 | 98 | ||
99 | {-# INLINABLE dot #-} | 99 | {-# INLINABLE dot #-} |
100 | Vector4 ax ay az aw `dot` Vector4 bx by bz bw = ax*bx + ay*by + az*bz + aw*bw | 100 | Vector4 ax ay az aw `dot` Vector4 bx by bz bw = ax*bx + ay*by + az*bz + aw*bw |
101 | 101 | ||
102 | {-# INLINABLE normSq #-} | 102 | {-# INLINABLE normSq #-} |
103 | normSq (Vector4 ax ay az aw) = ax*ax + ay*ay + az*az + aw*aw | 103 | normSq (Vector4 ax ay az aw) = ax*ax + ay*ay + az*az + aw*aw |
104 | 104 | ||
105 | {-# INLINABLE norm #-} | 105 | {-# INLINABLE norm #-} |
106 | norm = sqrt . normSq | 106 | norm = sqrt . normSq |
107 | 107 | ||
108 | {-# INLINABLE scale #-} | 108 | {-# INLINABLE scale #-} |
109 | scale s (Vector4 ax ay az aw) = Vector4 (s*ax) (s*ay) (s*az) (s*aw) | 109 | scale s (Vector4 ax ay az aw) = Vector4 (s*ax) (s*ay) (s*az) (s*aw) |
110 | 110 | ||
111 | {-# INLINABLE neg #-} | 111 | {-# INLINABLE neg #-} |
112 | neg (Vector4 ax ay az aw) = Vector4 (-ax) (-ay) (-az) (-aw) | 112 | neg (Vector4 ax ay az aw) = Vector4 (-ax) (-ay) (-az) (-aw) |
113 | 113 | ||
114 | {-# INLINABLE normalise #-} | 114 | {-# INLINABLE normalise #-} |
115 | normalise v = | 115 | normalise v = |
116 | let n' = norm v | 116 | let n' = norm v |
@@ -124,14 +124,14 @@ sizeFloat = sizeOf (undefined :: CFloat) | |||
124 | instance Storable Vector4 where | 124 | instance Storable Vector4 where |
125 | sizeOf _ = 4*sizeFloat | 125 | sizeOf _ = 4*sizeFloat |
126 | alignment _ = alignment (undefined :: CFloat) | 126 | alignment _ = alignment (undefined :: CFloat) |
127 | 127 | ||
128 | peek ptr = do | 128 | peek ptr = do |
129 | ax <- peekByteOff ptr 0 | 129 | ax <- peekByteOff ptr 0 |
130 | ay <- peekByteOff ptr $ 1 * sizeFloat | 130 | ay <- peekByteOff ptr $ 1 * sizeFloat |
131 | az <- peekByteOff ptr $ 2 * sizeFloat | 131 | az <- peekByteOff ptr $ 2 * sizeFloat |
132 | aw <- peekByteOff ptr $ 3 * sizeFloat | 132 | aw <- peekByteOff ptr $ 3 * sizeFloat |
133 | return (Vector4 ax ay az aw) | 133 | return (Vector4 ax ay az aw) |
134 | 134 | ||
135 | poke ptr (Vector4 ax ay az aw) = do | 135 | poke ptr (Vector4 ax ay az aw) = do |
136 | pokeByteOff ptr 0 ax | 136 | pokeByteOff ptr 0 ax |
137 | pokeByteOff ptr (1 * sizeFloat) ay | 137 | pokeByteOff ptr (1 * sizeFloat) ay |
diff --git a/Spear/Scene/GameObject.hs b/Spear/Scene/GameObject.hs deleted file mode 100644 index 190d0a5..0000000 --- a/Spear/Scene/GameObject.hs +++ /dev/null | |||
@@ -1,320 +0,0 @@ | |||
1 | module Spear.Scene.GameObject | ||
2 | ( | ||
3 | GameObject | ||
4 | , GameStyle(..) | ||
5 | , Window(..) | ||
6 | , AM.AnimationSpeed | ||
7 | -- * Construction | ||
8 | , goNew | ||
9 | -- * Accessors | ||
10 | , currentAnimation | ||
11 | --, goAABB | ||
12 | --, goAABBs | ||
13 | , collisioners | ||
14 | , goRPGtransform | ||
15 | , numCollisioners | ||
16 | , renderer | ||
17 | , window | ||
18 | -- * Manipulation | ||
19 | , goUpdate | ||
20 | , setAnimation | ||
21 | , setAnimationSpeed | ||
22 | , setAxis | ||
23 | , withCollisioners | ||
24 | , setCollisioners | ||
25 | , setWindow | ||
26 | -- * Rendering | ||
27 | , goRender | ||
28 | -- * Collision | ||
29 | , goCollide | ||
30 | ) | ||
31 | where | ||
32 | |||
33 | |||
34 | import Spear.GL | ||
35 | import Spear.Math.AABB | ||
36 | import qualified Spear.Math.Camera as Cam | ||
37 | import Spear.Math.Collision as Col | ||
38 | import qualified Spear.Math.Matrix3 as M3 | ||
39 | import qualified Spear.Math.Matrix4 as M4 | ||
40 | import Spear.Math.MatrixUtils | ||
41 | import qualified Spear.Math.Spatial2 as S2 | ||
42 | import qualified Spear.Math.Spatial3 as S3 | ||
43 | import Spear.Math.Utils | ||
44 | import Spear.Math.Vector | ||
45 | import qualified Spear.Render.AnimatedModel as AM | ||
46 | import Spear.Render.Program | ||
47 | import Spear.Render.StaticModel as SM | ||
48 | |||
49 | import Data.Fixed (mod') | ||
50 | import Data.List (foldl') | ||
51 | |||
52 | |||
53 | -- | Game style. | ||
54 | data GameStyle | ||
55 | = RPG -- ^ RPG or RTS style game. | ||
56 | | PLT -- ^ Platformer or space invaders style game. | ||
57 | |||
58 | |||
59 | data Window = Window | ||
60 | { projInv :: !M4.Matrix4 | ||
61 | , viewInv :: !M4.Matrix4 | ||
62 | , vpx :: !Float | ||
63 | , vpy :: !Float | ||
64 | , width :: !Float | ||
65 | , height :: !Float | ||
66 | } | ||
67 | |||
68 | |||
69 | dummyWindow = Window M4.id M4.id 0 0 640 480 | ||
70 | |||
71 | |||
72 | -- | An object in the game scene. | ||
73 | data GameObject = GameObject | ||
74 | { gameStyle :: !GameStyle | ||
75 | , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) | ||
76 | , collisioners :: ![Collisioner2] | ||
77 | , transform :: !M3.Matrix3 | ||
78 | , axis :: !Vector3 | ||
79 | , angle :: !Float | ||
80 | , window :: !Window | ||
81 | } | ||
82 | |||
83 | |||
84 | instance S2.Spatial2 GameObject where | ||
85 | |||
86 | move v go = go | ||
87 | { collisioners = fmap (Col.move v) $ collisioners go | ||
88 | , transform = M3.translv v * transform go | ||
89 | } | ||
90 | |||
91 | moveFwd s go = | ||
92 | let m = transform go | ||
93 | v = scale s $ M3.forward m | ||
94 | in go | ||
95 | { collisioners = fmap (Col.move v) $ collisioners go | ||
96 | , transform = M3.translv v * m | ||
97 | } | ||
98 | |||
99 | moveBack s go = | ||
100 | let m = transform go | ||
101 | v = scale (-s) $ M3.forward m | ||
102 | in go | ||
103 | { collisioners = fmap (Col.move v) $ collisioners go | ||
104 | , transform = M3.translv v * m | ||
105 | } | ||
106 | |||
107 | strafeLeft s go = | ||
108 | let m = transform go | ||
109 | v = scale (-s) $ M3.right m | ||
110 | in go | ||
111 | { collisioners = fmap (Col.move v) $ collisioners go | ||
112 | , transform = M3.translv v * m | ||
113 | } | ||
114 | |||
115 | strafeRight s go = | ||
116 | let m = transform go | ||
117 | v = scale s $ M3.right m | ||
118 | in go | ||
119 | { collisioners = fmap (Col.move v) $ collisioners go | ||
120 | , transform = M3.translv v * m | ||
121 | } | ||
122 | |||
123 | rotate a go = | ||
124 | go | ||
125 | { transform = transform go * M3.rot a | ||
126 | , angle = (angle go + a) `mod'` 360 | ||
127 | } | ||
128 | |||
129 | setRotation a go = | ||
130 | go | ||
131 | { transform = M3.translation (transform go) * M3.rot a | ||
132 | , angle = a | ||
133 | } | ||
134 | |||
135 | pos go = M3.position . transform $ go | ||
136 | |||
137 | fwd go = M3.forward . transform $ go | ||
138 | |||
139 | up go = M3.up . transform $ go | ||
140 | |||
141 | right go = M3.right . transform $ go | ||
142 | |||
143 | transform go = Spear.Scene.GameObject.transform go | ||
144 | |||
145 | setTransform mat go = go { transform = mat } | ||
146 | |||
147 | setPos pos go = | ||
148 | let m = transform go | ||
149 | in go { transform = M3.transform (M3.right m) (M3.forward m) pos } | ||
150 | |||
151 | lookAt p go = | ||
152 | let position = S2.pos go | ||
153 | fwd = normalise $ p - position | ||
154 | r = perp fwd | ||
155 | toDeg = (*(180/pi)) | ||
156 | viewI = viewInv . window $ go | ||
157 | p1 = viewToWorld2d position viewI | ||
158 | p2 = viewToWorld2d (position + fwd) viewI | ||
159 | f = normalise $ p2 - p1 | ||
160 | in | ||
161 | go | ||
162 | { transform = M3.transform r fwd position | ||
163 | , angle = 180 - | ||
164 | if x f > 0 | ||
165 | then toDeg . acos $ f `dot` unity2 | ||
166 | else (+180) . toDeg . acos $ f `dot` (-unity2) | ||
167 | } | ||
168 | |||
169 | |||
170 | -- | Create a new game object. | ||
171 | goNew :: GameStyle | ||
172 | -> Either StaticModelResource AM.AnimatedModelResource | ||
173 | -> [Collisioner2] | ||
174 | -> M3.Matrix3 -- ^ Transform | ||
175 | -> Vector3 -- ^ Axis of rotation | ||
176 | -> GameObject | ||
177 | |||
178 | goNew style (Left smr) cols transf axis = GameObject | ||
179 | style (Left $ SM.staticModelRenderer smr) cols transf axis 0 dummyWindow | ||
180 | |||
181 | goNew style (Right amr) cols transf axis = GameObject | ||
182 | style (Right $ AM.animatedModelRenderer 1 amr) cols transf axis 0 dummyWindow | ||
183 | |||
184 | |||
185 | goUpdate :: Float -> GameObject -> GameObject | ||
186 | goUpdate dt go = | ||
187 | let rend = renderer go | ||
188 | rend' = case rend of | ||
189 | Left _ -> rend | ||
190 | Right amr -> Right $ AM.update dt amr | ||
191 | in go | ||
192 | { renderer = rend' | ||
193 | } | ||
194 | |||
195 | |||
196 | -- | Get the game object's ith bounding box. | ||
197 | --goAABB :: Int -> GameObject -> AABB2 | ||
198 | --goAABB i = getAABB . flip (!!) i . collisioners | ||
199 | |||
200 | |||
201 | -- | Get the game object's bounding boxes. | ||
202 | --goAABBs :: GameObject -> [AABB2] | ||
203 | --goAABBs = fmap getAABB . collisioners | ||
204 | |||
205 | |||
206 | -- | Get the game object's 3D transform. | ||
207 | goRPGtransform :: GameObject -> M4.Matrix4 | ||
208 | goRPGtransform go = | ||
209 | let viewI = viewInv . window $ go | ||
210 | in rpgTransform 0 (angle go) (axis go) (S2.pos go) viewI | ||
211 | |||
212 | |||
213 | -- | Get the game object's current animation. | ||
214 | currentAnimation :: Enum a => GameObject -> a | ||
215 | currentAnimation go = case renderer go of | ||
216 | Left _ -> toEnum 0 | ||
217 | Right amr -> AM.currentAnimation amr | ||
218 | |||
219 | |||
220 | -- | Return the game object's number of collisioners. | ||
221 | numCollisioners :: GameObject -> Int | ||
222 | numCollisioners = length . collisioners | ||
223 | |||
224 | |||
225 | -- | Set the game object's current animation. | ||
226 | setAnimation :: Enum a => a -> GameObject -> GameObject | ||
227 | setAnimation a go = case renderer go of | ||
228 | Left _ -> go | ||
229 | Right amr -> go { renderer = Right $ AM.setAnimation a amr } | ||
230 | |||
231 | |||
232 | -- | Set the game object's animation speed. | ||
233 | setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject | ||
234 | setAnimationSpeed s go = case renderer go of | ||
235 | Left _ -> go | ||
236 | Right amr -> go { renderer = Right $ AM.setAnimationSpeed s amr } | ||
237 | |||
238 | |||
239 | -- | Set the game object's axis of rotation. | ||
240 | setAxis :: Vector3 -> GameObject -> GameObject | ||
241 | setAxis ax go = go { axis = ax } | ||
242 | |||
243 | |||
244 | -- | Set the game object's collisioners. | ||
245 | setCollisioners :: [Collisioner2] -> GameObject -> GameObject | ||
246 | setCollisioners cols go = go { collisioners = cols } | ||
247 | |||
248 | |||
249 | -- | Set the game object's window. | ||
250 | setWindow :: Window -> GameObject -> GameObject | ||
251 | setWindow wnd go = go { window = wnd } | ||
252 | |||
253 | |||
254 | -- | Manipulate the game object's collisioners. | ||
255 | withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject | ||
256 | withCollisioners go f = go { collisioners = f $ collisioners go } | ||
257 | |||
258 | |||
259 | -- | Render the game object. | ||
260 | goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO () | ||
261 | goRender sprog aprog cam go = | ||
262 | let spu = staticProgramUniforms sprog | ||
263 | apu = animatedProgramUniforms aprog | ||
264 | style = gameStyle go | ||
265 | axis' = axis go | ||
266 | a = angle go | ||
267 | proj = Cam.projection cam | ||
268 | view = M4.inverseTransform $ S3.transform cam | ||
269 | transf = S2.transform go | ||
270 | normal = fastNormalMatrix modelview | ||
271 | modelview = case style of | ||
272 | RPG -> view * goRPGtransform go | ||
273 | PLT -> view * pltTransform transf | ||
274 | in case renderer go of | ||
275 | Left smr -> | ||
276 | goRender' style a axis' sprog spu modelview proj normal | ||
277 | (SM.bind spu smr) (SM.render spu smr) | ||
278 | Right amr -> | ||
279 | goRender' style a axis' aprog apu modelview proj normal | ||
280 | (AM.bind apu amr) (AM.render apu amr) | ||
281 | |||
282 | |||
283 | type Bind = IO () | ||
284 | |||
285 | type Render = IO () | ||
286 | |||
287 | |||
288 | goRender' :: (ProgramUniforms u, Program p) | ||
289 | => GameStyle | ||
290 | -> Float | ||
291 | -> Vector3 | ||
292 | -> p | ||
293 | -> u | ||
294 | -> M4.Matrix4 -- Modelview | ||
295 | -> M4.Matrix4 -- Projection | ||
296 | -> M3.Matrix3 -- Normal matrix | ||
297 | -> Bind | ||
298 | -> Render | ||
299 | -> IO () | ||
300 | goRender' style a axis prog uniforms modelview proj normal bindRenderer render = | ||
301 | let | ||
302 | in do | ||
303 | useProgram . program $ prog | ||
304 | uniform (projLoc uniforms) proj | ||
305 | uniform (modelviewLoc uniforms) modelview | ||
306 | uniform (normalmatLoc uniforms) normal | ||
307 | bindRenderer | ||
308 | render | ||
309 | |||
310 | |||
311 | -- | Return 'True' if the given game objects collide, 'False' otherwise. | ||
312 | goCollide :: GameObject -> GameObject -> Bool | ||
313 | goCollide go1 go2 = | ||
314 | let cols1 = collisioners go1 | ||
315 | cols2 = collisioners go2 | ||
316 | c1 = cols1 !! 0 | ||
317 | c2 = cols2 !! 0 | ||
318 | in | ||
319 | if length cols1 == 0 || length cols2 == 0 then False | ||
320 | else c1 `collide` c2 /= NoCollision \ No newline at end of file | ||
diff --git a/Spear/Scene/Light.hs b/Spear/Scene/Light.hs deleted file mode 100644 index fb4225b..0000000 --- a/Spear/Scene/Light.hs +++ /dev/null | |||
@@ -1,31 +0,0 @@ | |||
1 | module Spear.Scene.Light | ||
2 | ( | ||
3 | Light(..) | ||
4 | ) | ||
5 | where | ||
6 | |||
7 | |||
8 | import qualified Spear.Math.Matrix4 as M | ||
9 | import qualified Spear.Math.Spatial3 as S | ||
10 | import Spear.Math.Vector | ||
11 | |||
12 | |||
13 | data Light | ||
14 | = PointLight | ||
15 | { ambient :: Vector3 | ||
16 | , diffuse :: Vector3 | ||
17 | , specular :: Vector3 | ||
18 | , transform :: M.Matrix4 | ||
19 | } | ||
20 | | DirectionalLight | ||
21 | { ambient :: Vector3 | ||
22 | , diffuse :: Vector3 | ||
23 | , specular :: Vector3 | ||
24 | , direction :: Vector3 | ||
25 | } | ||
26 | | SpotLight | ||
27 | { ambient :: Vector3 | ||
28 | , diffuse :: Vector3 | ||
29 | , specular :: Vector3 | ||
30 | , transform :: M.Matrix4 | ||
31 | } | ||
diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs index 43ed404..7c072e8 100644 --- a/Spear/Scene/Loader.hs +++ b/Spear/Scene/Loader.hs | |||
@@ -1,12 +1,9 @@ | |||
1 | module Spear.Scene.Loader | 1 | module Spear.Scene.Loader |
2 | ( | 2 | ( |
3 | SceneResources(..) | 3 | SceneResources(..) |
4 | , CreateGameObject | ||
5 | , loadScene | 4 | , loadScene |
6 | , validate | 5 | , validate |
7 | , resourceMap | 6 | , resourceMap |
8 | , loadGO | ||
9 | , loadObjects | ||
10 | , value | 7 | , value |
11 | , unspecified | 8 | , unspecified |
12 | , mandatory | 9 | , mandatory |
@@ -29,9 +26,7 @@ import Spear.Render.AnimatedModel as AM | |||
29 | import Spear.Render.Material | 26 | import Spear.Render.Material |
30 | import Spear.Render.Program | 27 | import Spear.Render.Program |
31 | import Spear.Render.StaticModel as SM | 28 | import Spear.Render.StaticModel as SM |
32 | import Spear.Scene.GameObject as GO | ||
33 | import Spear.Scene.Graph | 29 | import Spear.Scene.Graph |
34 | import Spear.Scene.Light | ||
35 | import Spear.Scene.SceneResources | 30 | import Spear.Scene.SceneResources |
36 | 31 | ||
37 | import Control.Monad.State.Strict | 32 | import Control.Monad.State.Strict |
@@ -68,7 +63,6 @@ resourceMap' node@(SceneLeaf nid props) = do | |||
68 | case nid of | 63 | case nid of |
69 | "shader-program" -> newShaderProgram node | 64 | "shader-program" -> newShaderProgram node |
70 | "model" -> newModel node | 65 | "model" -> newModel node |
71 | "light" -> newLight node | ||
72 | x -> return () | 66 | x -> return () |
73 | 67 | ||
74 | resourceMap' node@(SceneNode nid props children) = do | 68 | resourceMap' node@(SceneNode nid props children) = do |
@@ -296,73 +290,6 @@ loadShader shaderType ((stype, file):xs) = | |||
296 | loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader | 290 | loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader |
297 | loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file | 291 | loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file |
298 | 292 | ||
299 | newLight :: SceneGraph -> Loader () | ||
300 | newLight _ = return () | ||
301 | |||
302 | -------------------- | ||
303 | -- Object Loading -- | ||
304 | -------------------- | ||
305 | |||
306 | loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject | ||
307 | loadGO style sceneRes props transf = do | ||
308 | modelName <- asString . mandatory "model" $ props | ||
309 | axis <- asVec3 . mandatory "axis" $ props | ||
310 | let animSpeed = asFloat . value "animation-speed" $ props | ||
311 | go <- case getAnimatedModel sceneRes modelName of | ||
312 | Just model -> | ||
313 | return $ goNew style (Right model) [] transf axis | ||
314 | Nothing -> | ||
315 | case getStaticModel sceneRes modelName of | ||
316 | Just model -> | ||
317 | return $ goNew style (Left model) [] transf axis | ||
318 | Nothing -> | ||
319 | gameError $ "model " ++ modelName ++ " not found" | ||
320 | return $ case animSpeed of | ||
321 | Nothing -> go | ||
322 | Just s -> GO.setAnimationSpeed s go | ||
323 | |||
324 | type CreateGameObject m a | ||
325 | = String -- ^ The object's name. | ||
326 | -> SceneResources | ||
327 | -> [Property] | ||
328 | -> Matrix3 -- ^ The object's transform. | ||
329 | -> m a | ||
330 | |||
331 | -- | Load objects from the given 'SceneGraph'. | ||
332 | loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] | ||
333 | loadObjects newGO sceneRes g = | ||
334 | case node "layout" g of | ||
335 | Nothing -> return [] | ||
336 | Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n | ||
337 | |||
338 | -- to-do: use a strict accumulator and make loadObjects tail recursive. | ||
339 | newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] | ||
340 | newObject newGO sceneRes (SceneNode nid props children) = | ||
341 | let o = newObject' newGO sceneRes nid props | ||
342 | in o : (concat $ fmap (newObject newGO sceneRes) children) | ||
343 | |||
344 | newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] | ||
345 | |||
346 | newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a | ||
347 | newObject' newGO sceneRes nid props = do | ||
348 | -- Optional properties. | ||
349 | let goType = (asString $ value "type" props) `unspecified` "unknown" | ||
350 | position = (asVec2 $ value "position" props) `unspecified` vec2 0 0 | ||
351 | rotation = (asVec2 $ value "rotation" props) `unspecified` vec2 0 0 | ||
352 | right' = (asVec2 $ value "right" props) `unspecified` vec2 1 0 | ||
353 | up' = asVec2 $ value "up" props | ||
354 | scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1 | ||
355 | |||
356 | -- Compute the object's vectors if an up/forward vector has been specified. | ||
357 | let (right, up) = vectors up' | ||
358 | |||
359 | newGO goType sceneRes props (M3.transform right up position) | ||
360 | |||
361 | vectors :: Maybe Vector2 -> (Vector2, Vector2) | ||
362 | vectors up = case up of | ||
363 | Nothing -> (unitx2, unity2) | ||
364 | Just u -> (perp u, u) | ||
365 | |||
366 | ---------------------- | 293 | ---------------------- |
367 | -- Helper functions -- | 294 | -- Helper functions -- |
368 | ---------------------- | 295 | ---------------------- |
diff --git a/Spear/Scene/SceneResources.hs b/Spear/Scene/SceneResources.hs index 3c7d204..de2fc80 100644 --- a/Spear/Scene/SceneResources.hs +++ b/Spear/Scene/SceneResources.hs | |||
@@ -24,7 +24,6 @@ import Spear.Render.AnimatedModel | |||
24 | import Spear.Render.Material | 24 | import Spear.Render.Material |
25 | import Spear.Render.Program | 25 | import Spear.Render.Program |
26 | import Spear.Render.StaticModel | 26 | import Spear.Render.StaticModel |
27 | import Spear.Scene.Light | ||
28 | 27 | ||
29 | import Data.Map as M | 28 | import Data.Map as M |
30 | 29 | ||
@@ -36,12 +35,11 @@ data SceneResources = SceneResources | |||
36 | , textures :: Map String Texture | 35 | , textures :: Map String Texture |
37 | , staticModels :: Map String StaticModelResource | 36 | , staticModels :: Map String StaticModelResource |
38 | , animatedModels :: Map String AnimatedModelResource | 37 | , animatedModels :: Map String AnimatedModelResource |
39 | , lights :: [Light] | ||
40 | } | 38 | } |
41 | 39 | ||
42 | -- | Build an empty instance of 'SceneResources'. | 40 | -- | Build an empty instance of 'SceneResources'. |
43 | emptySceneResources = | 41 | emptySceneResources = |
44 | SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty [] | 42 | SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty |
45 | 43 | ||
46 | -- | Get the shader specified by the given string. | 44 | -- | Get the shader specified by the given string. |
47 | getShader :: SceneResources -> String -> Maybe GLSLShader | 45 | getShader :: SceneResources -> String -> Maybe GLSLShader |
diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc index 16f377e..60ae9d7 100644 --- a/Spear/Sys/Timer.hsc +++ b/Spear/Sys/Timer.hsc | |||
@@ -1,4 +1,4 @@ | |||
1 | {-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} | 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} |
2 | module Spear.Sys.Timer | 2 | module Spear.Sys.Timer |
3 | ( | 3 | ( |
4 | Timer | 4 | Timer |
diff --git a/Spear/Window.hs b/Spear/Window.hs new file mode 100644 index 0000000..1762da0 --- /dev/null +++ b/Spear/Window.hs | |||
@@ -0,0 +1,311 @@ | |||
1 | module Spear.Window | ||
2 | ( | ||
3 | -- * Setup | ||
4 | Dimensions | ||
5 | , Context | ||
6 | , WindowTitle | ||
7 | , FrameCap | ||
8 | , DisplayBits(..) | ||
9 | , WindowMode(..) | ||
10 | -- * Window | ||
11 | , Window | ||
12 | , Width | ||
13 | , Height | ||
14 | , Init | ||
15 | , withWindow | ||
16 | , events | ||
17 | -- * Animation | ||
18 | , Dt | ||
19 | , Step | ||
20 | , loop | ||
21 | , GLFW.swapBuffers | ||
22 | -- * Input | ||
23 | , InputEvent(..) | ||
24 | , Key(..) | ||
25 | , MouseButton(..) | ||
26 | , MouseProp(..) | ||
27 | , MousePos | ||
28 | , MouseDelta | ||
29 | ) | ||
30 | where | ||
31 | |||
32 | import Spear.Game | ||
33 | import Spear.Sys.Timer as Timer | ||
34 | |||
35 | import Data.Char (ord) | ||
36 | import Control.Concurrent.MVar | ||
37 | import Control.Monad (when) | ||
38 | import Control.Monad.IO.Class | ||
39 | import qualified Graphics.UI.GLFW as GLFW | ||
40 | import Graphics.UI.GLFW (DisplayBits(..), WindowMode(..)) | ||
41 | import qualified Graphics.Rendering.OpenGL as GL | ||
42 | |||
43 | type Width = Int | ||
44 | type Height = Int | ||
45 | |||
46 | -- | Window dimensions. | ||
47 | type Dimensions = (Width, Height) | ||
48 | |||
49 | -- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). | ||
50 | type Context = (Int, Int) | ||
51 | |||
52 | type WindowTitle = String | ||
53 | |||
54 | type CloseRequest = MVar Bool | ||
55 | |||
56 | -- | A window. | ||
57 | data Window = Window | ||
58 | { closeRequest :: CloseRequest | ||
59 | , inputEvents :: MVar [InputEvent] | ||
60 | } | ||
61 | |||
62 | -- | Poll the window's events. | ||
63 | events :: MonadIO m => Window -> m [InputEvent] | ||
64 | events wnd = liftIO $ do | ||
65 | es <- tryTakeMVar (inputEvents wnd) >>= \xs -> case xs of | ||
66 | Nothing -> return [] | ||
67 | Just es -> return es | ||
68 | putMVar (inputEvents wnd) [] | ||
69 | return es | ||
70 | |||
71 | -- | Game initialiser. | ||
72 | type Init s = Window -> Game () s | ||
73 | |||
74 | withWindow :: MonadIO m | ||
75 | => Dimensions -> [DisplayBits] -> WindowMode -> Context | ||
76 | -> Maybe WindowTitle | ||
77 | -> Init s | ||
78 | -> (Window -> Game s a) | ||
79 | -> m (Either String a) | ||
80 | withWindow dim@(w,h) displayBits windowMode glVersion windowTitle init run = | ||
81 | liftIO $ flip runGame' () $ do | ||
82 | glfwInit | ||
83 | wnd <- setup dim displayBits windowMode glVersion windowTitle | ||
84 | gameState <- init wnd | ||
85 | result <- evalSubGame (run wnd) gameState | ||
86 | gameIO GLFW.closeWindow | ||
87 | gameIO GLFW.terminate | ||
88 | return result | ||
89 | |||
90 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | ||
91 | -> Game s Window | ||
92 | setup (w, h) displayBits windowMode (major, minor) wndTitle = do | ||
93 | closeRequest <- liftIO newEmptyMVar | ||
94 | inputEvents <- liftIO newEmptyMVar | ||
95 | let onResize' = onResize inputEvents | ||
96 | let dimensions = GL.Size (fromIntegral w) (fromIntegral h) | ||
97 | result <- liftIO $ do | ||
98 | GLFW.openWindowHint GLFW.OpenGLVersionMajor major | ||
99 | GLFW.openWindowHint GLFW.OpenGLVersionMinor minor | ||
100 | compat (major, minor) | ||
101 | GLFW.disableSpecial GLFW.AutoPollEvent | ||
102 | GLFW.openWindow dimensions (defaultBits displayBits) windowMode | ||
103 | when (not result) $ gameError "GLFW.openWindow failed" | ||
104 | liftIO $ do | ||
105 | GLFW.windowTitle GL.$= case wndTitle of | ||
106 | Nothing -> "Spear Game Framework" | ||
107 | Just title -> title | ||
108 | GLFW.windowCloseCallback GL.$= (onWindowClose closeRequest) | ||
109 | GLFW.windowSizeCallback GL.$= onResize' | ||
110 | GLFW.keyCallback GL.$= onKey inputEvents | ||
111 | GLFW.charCallback GL.$= onChar inputEvents | ||
112 | GLFW.mouseButtonCallback GL.$= onMouseButton inputEvents | ||
113 | onMouseMove inputEvents >>= (GLFW.mousePosCallback GL.$=) | ||
114 | onResize' (GL.Size (fromIntegral w) (fromIntegral h)) | ||
115 | return $ Spear.Window.Window closeRequest inputEvents | ||
116 | |||
117 | defaultBits [] = [DisplayRGBBits 8 8 8] | ||
118 | defaultBits xs = xs | ||
119 | |||
120 | compat (major, minor) | ||
121 | | major >= 3 = GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCompatProfile | ||
122 | | otherwise = return () | ||
123 | |||
124 | glfwInit :: Game s () | ||
125 | glfwInit = do | ||
126 | result <- liftIO GLFW.initialize | ||
127 | case result of | ||
128 | False -> gameError "GLFW.initialize failed" | ||
129 | True -> return () | ||
130 | |||
131 | -- | Time elapsed since the last frame. | ||
132 | type Dt = Float | ||
133 | |||
134 | -- | Return true if the application should continue running, false otherwise. | ||
135 | type Step s = Dt -> Game s (Bool) | ||
136 | |||
137 | -- | Maximum frame rate. | ||
138 | type FrameCap = Int | ||
139 | |||
140 | -- | Run the application's main loop. | ||
141 | loop :: Maybe FrameCap -> Step s -> Window -> Game s () | ||
142 | loop (Just maxFPS) step wnd = loopCapped maxFPS step wnd | ||
143 | loop Nothing step wnd = do | ||
144 | timer <- gameIO $ start newTimer | ||
145 | run (closeRequest wnd) timer step | ||
146 | return () | ||
147 | |||
148 | run :: CloseRequest -> Timer -> Step s -> Game s () | ||
149 | run closeRequest timer step = do | ||
150 | timer' <- gameIO $ tick timer | ||
151 | continue <- step $ getDelta timer' | ||
152 | close <- gameIO $ getRequest closeRequest | ||
153 | when (continue && (not close)) $ run closeRequest timer' step | ||
154 | |||
155 | loopCapped :: Int -> Step s -> Window -> Game s () | ||
156 | loopCapped maxFPS step wnd = do | ||
157 | let ddt = 1.0 / (fromIntegral maxFPS) | ||
158 | closeReq = closeRequest wnd | ||
159 | frameTimer <- gameIO $ start newTimer | ||
160 | controlTimer <- gameIO $ start newTimer | ||
161 | runCapped closeReq ddt frameTimer controlTimer step | ||
162 | return () | ||
163 | |||
164 | runCapped :: CloseRequest -> Float -> Timer -> Timer -> Step s -> Game s () | ||
165 | runCapped closeRequest ddt frameTimer controlTimer step = do | ||
166 | controlTimer' <- gameIO $ tick controlTimer | ||
167 | frameTimer' <- gameIO $ tick frameTimer | ||
168 | continue <- step $ getDelta frameTimer' | ||
169 | close <- gameIO $ getRequest closeRequest | ||
170 | controlTimer'' <- gameIO $ tick controlTimer' | ||
171 | let dt = getDelta controlTimer'' | ||
172 | when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) | ||
173 | when (continue && (not close)) $ | ||
174 | runCapped closeRequest ddt frameTimer' controlTimer'' step | ||
175 | |||
176 | getRequest :: MVar Bool -> IO Bool | ||
177 | getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of | ||
178 | Nothing -> False | ||
179 | Just x -> x | ||
180 | |||
181 | onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback | ||
182 | onWindowClose closeRequest = putMVar closeRequest True >> return False | ||
183 | |||
184 | onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback | ||
185 | onResize es (GL.Size w h) = addEvent es $ Resize (fromIntegral w) (fromIntegral h) | ||
186 | |||
187 | onKey :: MVar [InputEvent] -> GLFW.KeyCallback | ||
188 | onKey es key GLFW.Press = addEvent es $ KeyDown (fromGLFWkey key) | ||
189 | onKey es key GLFW.Release = addEvent es $ KeyUp (fromGLFWkey key) | ||
190 | |||
191 | onChar :: MVar [InputEvent] -> GLFW.CharCallback | ||
192 | onChar es c GLFW.Press = addEvent es $ KeyDown (fromGLFWkey (GLFW.CharKey c)) | ||
193 | onChar es c GLFW.Release = addEvent es $ KeyUp (fromGLFWkey (GLFW.CharKey c)) | ||
194 | |||
195 | onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback | ||
196 | onMouseButton es bt GLFW.Press = addEvent es $ MouseDown (fromGLFWbutton bt) | ||
197 | onMouseButton es bt GLFW.Release = addEvent es $ MouseUp (fromGLFWbutton bt) | ||
198 | |||
199 | onMouseMove :: MVar [InputEvent] -> IO GLFW.MousePosCallback | ||
200 | onMouseMove es = newEmptyMVar >>= return . flip onMouseMove' es | ||
201 | |||
202 | onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.MousePosCallback | ||
203 | onMouseMove' oldPos es (GL.Position x y) = do | ||
204 | let (x',y') = (fromIntegral x, fromIntegral y) | ||
205 | (old_x, old_y) <- tryTakeMVar oldPos >>= \x -> case x of | ||
206 | Nothing -> return (x',y') | ||
207 | Just p -> return p | ||
208 | let delta = (x'-old_x, y'-old_y) | ||
209 | putMVar oldPos (x',y') | ||
210 | addEvent es $ MouseMove (x',y') delta | ||
211 | |||
212 | replaceMVar :: MVar a -> a -> IO () | ||
213 | replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val | ||
214 | |||
215 | addEvent :: MVar [a] -> a -> IO () | ||
216 | addEvent mvar val = tryTakeMVar mvar >>= \xs -> case xs of | ||
217 | Nothing -> putMVar mvar [val] | ||
218 | Just es -> putMVar mvar (val:es) | ||
219 | |||
220 | -- Input | ||
221 | |||
222 | data InputEvent | ||
223 | = Resize Width Height | ||
224 | | KeyDown Key | ||
225 | | KeyUp Key | ||
226 | | MouseDown MouseButton | ||
227 | | MouseUp MouseButton | ||
228 | | MouseMove MousePos MouseDelta | ||
229 | deriving (Eq, Show) | ||
230 | |||
231 | data Key | ||
232 | = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H | ||
233 | | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P | ||
234 | | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X | ||
235 | | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5 | ||
236 | | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3 | ||
237 | | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 | ||
238 | | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN | ||
239 | | KEY_LEFT | KEY_RIGHT | KEY_UNKNOWN | ||
240 | deriving (Eq, Enum, Bounded, Show) | ||
241 | |||
242 | data MouseButton = LMB | RMB | MMB | ||
243 | deriving (Eq, Enum, Bounded, Show) | ||
244 | |||
245 | data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta | ||
246 | deriving (Eq, Enum, Bounded, Show) | ||
247 | |||
248 | type MousePos = (Int,Int) | ||
249 | type MouseDelta = (Int,Int) | ||
250 | |||
251 | fromGLFWkey :: GLFW.Key -> Key | ||
252 | fromGLFWkey (GLFW.CharKey 'A') = KEY_A | ||
253 | fromGLFWkey (GLFW.CharKey 'B') = KEY_B | ||
254 | fromGLFWkey (GLFW.CharKey 'C') = KEY_C | ||
255 | fromGLFWkey (GLFW.CharKey 'D') = KEY_D | ||
256 | fromGLFWkey (GLFW.CharKey 'E') = KEY_E | ||
257 | fromGLFWkey (GLFW.CharKey 'F') = KEY_F | ||
258 | fromGLFWkey (GLFW.CharKey 'G') = KEY_G | ||
259 | fromGLFWkey (GLFW.CharKey 'H') = KEY_H | ||
260 | fromGLFWkey (GLFW.CharKey 'I') = KEY_I | ||
261 | fromGLFWkey (GLFW.CharKey 'J') = KEY_J | ||
262 | fromGLFWkey (GLFW.CharKey 'K') = KEY_K | ||
263 | fromGLFWkey (GLFW.CharKey 'L') = KEY_L | ||
264 | fromGLFWkey (GLFW.CharKey 'M') = KEY_M | ||
265 | fromGLFWkey (GLFW.CharKey 'N') = KEY_N | ||
266 | fromGLFWkey (GLFW.CharKey 'O') = KEY_O | ||
267 | fromGLFWkey (GLFW.CharKey 'P') = KEY_P | ||
268 | fromGLFWkey (GLFW.CharKey 'Q') = KEY_Q | ||
269 | fromGLFWkey (GLFW.CharKey 'R') = KEY_R | ||
270 | fromGLFWkey (GLFW.CharKey 'S') = KEY_S | ||
271 | fromGLFWkey (GLFW.CharKey 'T') = KEY_T | ||
272 | fromGLFWkey (GLFW.CharKey 'U') = KEY_U | ||
273 | fromGLFWkey (GLFW.CharKey 'V') = KEY_V | ||
274 | fromGLFWkey (GLFW.CharKey 'W') = KEY_W | ||
275 | fromGLFWkey (GLFW.CharKey 'X') = KEY_X | ||
276 | fromGLFWkey (GLFW.CharKey 'Y') = KEY_Y | ||
277 | fromGLFWkey (GLFW.CharKey 'Z') = KEY_Z | ||
278 | fromGLFWkey (GLFW.CharKey '0') = KEY_0 | ||
279 | fromGLFWkey (GLFW.CharKey '1') = KEY_1 | ||
280 | fromGLFWkey (GLFW.CharKey '2') = KEY_2 | ||
281 | fromGLFWkey (GLFW.CharKey '3') = KEY_3 | ||
282 | fromGLFWkey (GLFW.CharKey '4') = KEY_4 | ||
283 | fromGLFWkey (GLFW.CharKey '5') = KEY_5 | ||
284 | fromGLFWkey (GLFW.CharKey '6') = KEY_6 | ||
285 | fromGLFWkey (GLFW.CharKey '7') = KEY_7 | ||
286 | fromGLFWkey (GLFW.CharKey '8') = KEY_8 | ||
287 | fromGLFWkey (GLFW.CharKey '9') = KEY_9 | ||
288 | fromGLFWkey (GLFW.CharKey ' ') = KEY_SPACE | ||
289 | fromGLFWkey (GLFW.SpecialKey GLFW.F1) = KEY_F1 | ||
290 | fromGLFWkey (GLFW.SpecialKey GLFW.F2) = KEY_F2 | ||
291 | fromGLFWkey (GLFW.SpecialKey GLFW.F3) = KEY_F3 | ||
292 | fromGLFWkey (GLFW.SpecialKey GLFW.F4) = KEY_F4 | ||
293 | fromGLFWkey (GLFW.SpecialKey GLFW.F5) = KEY_F5 | ||
294 | fromGLFWkey (GLFW.SpecialKey GLFW.F6) = KEY_F6 | ||
295 | fromGLFWkey (GLFW.SpecialKey GLFW.F7) = KEY_F7 | ||
296 | fromGLFWkey (GLFW.SpecialKey GLFW.F8) = KEY_F8 | ||
297 | fromGLFWkey (GLFW.SpecialKey GLFW.F9) = KEY_F9 | ||
298 | fromGLFWkey (GLFW.SpecialKey GLFW.F10) = KEY_F10 | ||
299 | fromGLFWkey (GLFW.SpecialKey GLFW.F11) = KEY_F11 | ||
300 | fromGLFWkey (GLFW.SpecialKey GLFW.F12) = KEY_F12 | ||
301 | fromGLFWkey (GLFW.SpecialKey GLFW.ESC) = KEY_ESC | ||
302 | fromGLFWkey (GLFW.SpecialKey GLFW.UP) = KEY_UP | ||
303 | fromGLFWkey (GLFW.SpecialKey GLFW.DOWN) = KEY_DOWN | ||
304 | fromGLFWkey (GLFW.SpecialKey GLFW.LEFT) = KEY_LEFT | ||
305 | fromGLFWkey (GLFW.SpecialKey GLFW.RIGHT) = KEY_RIGHT | ||
306 | fromGLFWkey _ = KEY_UNKNOWN | ||
307 | |||
308 | fromGLFWbutton :: GLFW.MouseButton -> MouseButton | ||
309 | fromGLFWbutton GLFW.ButtonLeft = LMB | ||
310 | fromGLFWbutton GLFW.ButtonRight = RMB | ||
311 | fromGLFWbutton GLFW.ButtonMiddle = MMB | ||
diff --git a/demos/pong/LICENSE b/demos/pong/LICENSE new file mode 100644 index 0000000..2ad9c8d --- /dev/null +++ b/demos/pong/LICENSE | |||
@@ -0,0 +1,30 @@ | |||
1 | Copyright (c) 2013, Marc Sunet | ||
2 | |||
3 | All rights reserved. | ||
4 | |||
5 | Redistribution and use in source and binary forms, with or without | ||
6 | modification, are permitted provided that the following conditions are met: | ||
7 | |||
8 | * Redistributions of source code must retain the above copyright | ||
9 | notice, this list of conditions and the following disclaimer. | ||
10 | |||
11 | * Redistributions in binary form must reproduce the above | ||
12 | copyright notice, this list of conditions and the following | ||
13 | disclaimer in the documentation and/or other materials provided | ||
14 | with the distribution. | ||
15 | |||
16 | * Neither the name of Marc Sunet nor the names of other | ||
17 | contributors may be used to endorse or promote products derived | ||
18 | from this software without specific prior written permission. | ||
19 | |||
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT | ||
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | ||
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs new file mode 100644 index 0000000..8c379ec --- /dev/null +++ b/demos/pong/Main.hs | |||
@@ -0,0 +1,86 @@ | |||
1 | module Main where | ||
2 | |||
3 | import Pong | ||
4 | |||
5 | import Spear.Math.AABB | ||
6 | import Spear.Math.Spatial2 | ||
7 | import Spear.Math.Vector | ||
8 | import Spear.Game | ||
9 | import Spear.Window | ||
10 | |||
11 | import Data.Maybe (mapMaybe) | ||
12 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
13 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
14 | |||
15 | data GameState = GameState | ||
16 | { wnd :: Window | ||
17 | , elapsed :: Double | ||
18 | , world :: [GameObject] | ||
19 | } | ||
20 | |||
21 | main = do | ||
22 | result <- run | ||
23 | case result of | ||
24 | Left err -> putStrLn err | ||
25 | Right _ -> return () | ||
26 | |||
27 | run = withWindow (640,480) [] Window (2,0) (Just "Pong") initGame | ||
28 | $ loop (Just 30) step | ||
29 | |||
30 | initGame wnd = do | ||
31 | gameIO $ do | ||
32 | GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 | ||
33 | GL.matrixMode $= GL.Modelview 0 | ||
34 | GL.loadIdentity | ||
35 | return $ GameState wnd 0 newWorld | ||
36 | |||
37 | step :: Dt -> Game GameState Bool | ||
38 | step dt = do | ||
39 | gs <- getGameState | ||
40 | evts <- events (wnd gs) | ||
41 | gameIO . process $ evts | ||
42 | let evts' = translate evts | ||
43 | modifyGameState $ \ gs -> gs | ||
44 | { world = stepWorld (elapsed gs) dt evts' (world gs) | ||
45 | , elapsed = elapsed gs + realToFrac dt } | ||
46 | getGameState >>= \gs -> gameIO . render $ world gs | ||
47 | return (not $ exitRequested evts) | ||
48 | |||
49 | render world = do | ||
50 | GL.clear [GL.ColorBuffer] | ||
51 | mapM_ renderGO world | ||
52 | swapBuffers | ||
53 | |||
54 | renderGO :: GameObject -> IO () | ||
55 | renderGO go = do | ||
56 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | ||
57 | (Vector2 xcenter ycenter) = pos go | ||
58 | (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | ||
59 | GL.preservingMatrix $ do | ||
60 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | ||
61 | GL.renderPrimitive (GL.TriangleStrip) $ do | ||
62 | GL.vertex (GL.Vertex2 xmin ymax) | ||
63 | GL.vertex (GL.Vertex2 xmin ymin) | ||
64 | GL.vertex (GL.Vertex2 xmax ymax) | ||
65 | GL.vertex (GL.Vertex2 xmax ymin) | ||
66 | |||
67 | process = mapM_ procEvent | ||
68 | procEvent (Resize w h) = do | ||
69 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) | ||
70 | GL.matrixMode $= GL.Projection | ||
71 | GL.loadIdentity | ||
72 | GL.ortho 0 1 0 1 (-1) 1 | ||
73 | GL.matrixMode $= GL.Modelview 0 | ||
74 | procEvent _ = return () | ||
75 | |||
76 | translate = mapMaybe translate' | ||
77 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | ||
78 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | ||
79 | translate' (KeyUp KEY_LEFT) = Just StopLeft | ||
80 | translate' (KeyUp KEY_RIGHT) = Just StopRight | ||
81 | translate' _ = Nothing | ||
82 | |||
83 | exitRequested = any (==(KeyDown KEY_ESC)) | ||
84 | |||
85 | f2d :: Float -> GL.GLdouble | ||
86 | f2d = realToFrac \ No newline at end of file | ||
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs new file mode 100644 index 0000000..9a3138b --- /dev/null +++ b/demos/pong/Pong.hs | |||
@@ -0,0 +1,174 @@ | |||
1 | module Pong | ||
2 | ( | ||
3 | GameEvent(..) | ||
4 | , GameObject | ||
5 | , newWorld | ||
6 | , stepWorld | ||
7 | , aabb | ||
8 | ) | ||
9 | where | ||
10 | |||
11 | import Spear.Math.AABB | ||
12 | import Spear.Math.Spatial2 | ||
13 | import Spear.Math.Vector | ||
14 | |||
15 | import Data.List (foldl') | ||
16 | import Data.Monoid | ||
17 | import GHC.Float (double2Float) | ||
18 | |||
19 | type Elapsed = Double | ||
20 | type Dt = Float | ||
21 | |||
22 | -- Step function | ||
23 | |||
24 | data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) } | ||
25 | |||
26 | sid :: Step a a | ||
27 | sid = Step $ \_ _ a -> (a, sid) | ||
28 | |||
29 | spure :: (a -> b) -> Step a b | ||
30 | spure f = Step $ \_ _ x -> (f x, spure f) | ||
31 | |||
32 | smap :: (a -> b) -> Step c a -> Step c b | ||
33 | smap f (Step s1) = Step $ \elapsed dt x -> | ||
34 | let (a, s') = s1 elapsed dt x | ||
35 | in (f a, smap f s') | ||
36 | |||
37 | (.>) :: Step a b -> Step b c -> Step a c | ||
38 | (Step s1) .> (Step s2) = Step $ \elapsed dt a -> | ||
39 | let (b, s1') = s1 elapsed dt a | ||
40 | (c, s2') = s2 elapsed dt b | ||
41 | in (c, s1' .> s2') | ||
42 | |||
43 | (.<) :: Step a b -> Step c a -> Step c b | ||
44 | (.<) = flip (.>) | ||
45 | |||
46 | sfst :: Step (a,b) a | ||
47 | sfst = spure $ \(a,_) -> a | ||
48 | |||
49 | ssnd :: Step (a,b) b | ||
50 | ssnd = spure $ \(_,b) -> b | ||
51 | |||
52 | -- Game events | ||
53 | |||
54 | data GameEvent | ||
55 | = MoveLeft | ||
56 | | MoveRight | ||
57 | | StopLeft | ||
58 | | StopRight | ||
59 | deriving Eq | ||
60 | |||
61 | -- Game objects | ||
62 | |||
63 | data GameObject = GameObject | ||
64 | { aabb :: AABB2 | ||
65 | , obj :: Obj2 | ||
66 | , gostep :: Step ([GameEvent], [GameObject], GameObject) GameObject | ||
67 | } | ||
68 | |||
69 | instance Spatial2 GameObject where | ||
70 | getObj2 = obj | ||
71 | setObj2 s o = s { obj = o } | ||
72 | |||
73 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | ||
74 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | ||
75 | |||
76 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | ||
77 | update elapsed dt evts gos go = | ||
78 | let (go', s') = step (gostep go) elapsed dt (evts, gos, go) | ||
79 | in go' { gostep = s' } | ||
80 | |||
81 | ballBox :: AABB2 | ||
82 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 | ||
83 | |||
84 | padSize = vec2 0.05 0.02 | ||
85 | |||
86 | padBox = AABB2 (-padSize) padSize | ||
87 | |||
88 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) | ||
89 | |||
90 | ballVelocity = Vector2 0.3 0.3 | ||
91 | |||
92 | newWorld = | ||
93 | [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity | ||
94 | , GameObject padBox (obj2 0.5 0.9) stepEnemy | ||
95 | , GameObject padBox (obj2 0.5 0.1) stepPlayer | ||
96 | ] | ||
97 | |||
98 | -- Generic steppers | ||
99 | |||
100 | ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject | ||
101 | ignore = spure $ \(_,_,go) -> go | ||
102 | |||
103 | ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject) | ||
104 | ignoreEvts = spure $ \(_, world, go) -> (world, go) | ||
105 | |||
106 | ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject) | ||
107 | ignoreGOs = spure $ \(evts, _, go) -> (evts, go) | ||
108 | |||
109 | -- Ball steppers | ||
110 | |||
111 | stepBall vel = ignoreEvts .> collideBall vel .> moveBall | ||
112 | |||
113 | collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject) | ||
114 | collideBall vel = Step $ \_ _ (gos, ball) -> | ||
115 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | ||
116 | collideCol = x pmin < 0 || x pmax > 1 | ||
117 | collideRow = y pmin < 0 || y pmax > 1 | ||
118 | || any (collide ball) (tail gos) | ||
119 | negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v | ||
120 | negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v | ||
121 | vel' = negx . negy $ vel | ||
122 | in ((vel', ball), collideBall vel') | ||
123 | |||
124 | collide go1 go2 = | ||
125 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) | ||
126 | = aabb go1 `aabbAdd` pos go1 | ||
127 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) | ||
128 | = aabb go2 `aabbAdd` pos go2 | ||
129 | in not $ xmax1 < xmin2 || xmin1 > xmax2 | ||
130 | || ymax1 < ymin2 || ymin1 > ymax2 | ||
131 | |||
132 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) | ||
133 | |||
134 | moveBall :: Step (Vector2, GameObject) GameObject | ||
135 | moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall) | ||
136 | |||
137 | -- Enemy stepper | ||
138 | |||
139 | stepEnemy = ignore .> movePad | ||
140 | |||
141 | movePad :: Step GameObject GameObject | ||
142 | movePad = Step $ \elapsed _ pad -> | ||
143 | let p = vec2 px 0.9 | ||
144 | px = double2Float (sin elapsed * 0.5 + 0.5) | ||
145 | * (1 - 2 * x padSize) | ||
146 | + x padSize | ||
147 | in (setPos p pad, movePad) | ||
148 | |||
149 | -- Player stepper | ||
150 | |||
151 | stepPlayer = ignoreGOs | ||
152 | .> moveGO False MoveLeft StopLeft | ||
153 | .> moveGO False MoveRight StopRight | ||
154 | .> ssnd | ||
155 | .> clamp | ||
156 | |||
157 | moveGO :: Bool -> GameEvent -> GameEvent | ||
158 | -> Step ([GameEvent], GameObject) ([GameEvent], GameObject) | ||
159 | moveGO moving start stop = Step $ \_ dt (evts, go) -> | ||
160 | let moving' = (moving || any (==start) evts) && not (any (==stop) evts) | ||
161 | dir = scale dt $ toDir moving' start | ||
162 | in ((evts, move dir go), moveGO moving' start stop) | ||
163 | |||
164 | clamp :: Step GameObject GameObject | ||
165 | clamp = spure $ \go -> | ||
166 | let p' = vec2 (clamp' x s (1 - s)) y | ||
167 | (Vector2 x y) = pos go | ||
168 | clamp' x a b = if x < a then a else if x > b then b else x | ||
169 | (Vector2 s _) = padSize | ||
170 | in setPos p' go | ||
171 | |||
172 | toDir True MoveLeft = vec2 (-1) 0 | ||
173 | toDir True MoveRight = vec2 1 0 | ||
174 | toDir _ _ = vec2 0 0 \ No newline at end of file | ||
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/demos/pong/Setup.hs | |||
@@ -0,0 +1,2 @@ | |||
1 | import Distribution.Simple | ||
2 | main = defaultMain | ||
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal new file mode 100644 index 0000000..bebedb9 --- /dev/null +++ b/demos/pong/pong.cabal | |||
@@ -0,0 +1,21 @@ | |||
1 | -- Initial pong.cabal generated by cabal init. For further documentation, | ||
2 | -- see http://haskell.org/cabal/users-guide/ | ||
3 | |||
4 | name: pong | ||
5 | version: 0.1.0.0 | ||
6 | synopsis: A pong clone | ||
7 | -- description: | ||
8 | license: BSD3 | ||
9 | license-file: LICENSE | ||
10 | author: Marc Sunet | ||
11 | -- maintainer: | ||
12 | -- copyright: | ||
13 | category: Game | ||
14 | build-type: Simple | ||
15 | cabal-version: >=1.8 | ||
16 | |||
17 | executable pong | ||
18 | -- hs-source-dirs: src | ||
19 | main-is: Main.hs | ||
20 | -- other-modules: | ||
21 | build-depends: base ==4.6.*, Spear, OpenGL | ||