aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeanne-Kamikaze <jeannekamikaze@gmail.com>2013-08-10 17:24:17 +0200
committerJeanne-Kamikaze <jeannekamikaze@gmail.com>2013-08-10 17:24:17 +0200
commite15a9cc51e31b5deb973d8583298aa130dd82b17 (patch)
treec7eca5402b85ccb9cb7de3928991f1b3a9d4e253
parent04313774991dc503844ddd2c47529aca8280aa6c (diff)
Added pong
Diffstat
-rw-r--r--.gitignore3
-rw-r--r--Spear.cabal11
-rw-r--r--Spear/App.hs10
-rw-r--r--Spear/App/Application.hs139
-rw-r--r--Spear/App/Input.hs265
-rw-r--r--Spear/Game.hs7
-rw-r--r--Spear/Math/AABB.hs4
-rw-r--r--Spear/Math/Entity.hs33
-rw-r--r--Spear/Math/MatrixUtils.hs9
-rw-r--r--Spear/Math/Spatial2.hs210
-rw-r--r--Spear/Math/Spatial3.hs270
-rw-r--r--Spear/Math/Vector/Vector2.hs28
-rw-r--r--Spear/Math/Vector/Vector3.hs2
-rw-r--r--Spear/Math/Vector/Vector4.hs34
-rw-r--r--Spear/Scene/GameObject.hs320
-rw-r--r--Spear/Scene/Light.hs31
-rw-r--r--Spear/Scene/Loader.hs73
-rw-r--r--Spear/Scene/SceneResources.hs4
-rw-r--r--Spear/Sys/Timer.hsc2
-rw-r--r--Spear/Window.hs311
-rw-r--r--demos/pong/LICENSE30
-rw-r--r--demos/pong/Main.hs86
-rw-r--r--demos/pong/Pong.hs174
-rw-r--r--demos/pong/Setup.hs2
-rw-r--r--demos/pong/pong.cabal21
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 @@
1demos/pong/dist/
2demos/pong/pong
3dist/
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 @@
1module Spear.App
2(
3 module Spear.App.Application
4, module Spear.App.Input
5)
6where
7
8
9import Spear.App.Application
10import 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 @@
1module 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)
20where
21
22import Spear.Game
23import Spear.Sys.Timer as Timer
24
25import Control.Concurrent.MVar
26import Control.Monad (when)
27import Control.Monad.IO.Class
28import Graphics.UI.GLFW as GLFW
29import Graphics.Rendering.OpenGL as GL
30
31-- | Window dimensions.
32type Dimensions = (Int, Int)
33
34-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor).
35type Context = (Int, Int)
36
37type WindowTitle = String
38
39-- Whether the user has closed the window.
40type CloseRequested = MVar Bool
41
42-- | Represents a window.
43data SpearWindow = SpearWindow
44 { closeRequest :: CloseRequested
45 }
46
47withWindow :: MonadIO m
48 => Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle
49 -> WindowSizeCallback -> (SpearWindow -> Game () a) -> m (Either String a)
50withWindow 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'.
63setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle
64 -> WindowSizeCallback -> Game s SpearWindow
65setup (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
83glfwInit :: Game s ()
84glfwInit = 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.
91type Update s = Float -> Game s (Bool)
92
93-- | Run the application's main loop.
94loop :: SpearWindow -> Update s -> Game s ()
95loop 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
102run :: CloseRequested -> Timer -> Update s -> Game s ()
103run 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.
110loopCapped :: SpearWindow -> Int -> Update s -> Game s ()
111loopCapped 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
121runCapped :: CloseRequested -> Float -> Timer -> Timer -> Update s -> Game s ()
122runCapped 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
133getRequest :: MVar Bool -> IO Bool
134getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of
135 Nothing -> False
136 Just x -> x
137
138onWindowClose :: MVar Bool -> WindowCloseCallback
139onWindowClose 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 @@
1module 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)
31where
32
33import Data.Char (ord)
34import qualified Data.Vector.Unboxed as V
35import qualified Graphics.UI.GLFW as GLFW
36import Graphics.Rendering.OpenGL.GL.CoordTrans
37import Graphics.Rendering.OpenGL.GL.StateVar
38
39data 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
50type Keyboard = Key -> Bool
51
52data MouseButton = LMB | RMB | MMB
53 deriving (Enum, Bounded)
54
55data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta
56 deriving Enum
57
58data Mouse = Mouse
59 { button :: MouseButton -> Bool
60 , property :: MouseProp -> Float
61 }
62
63data 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'.
75newKeyboard :: Keyboard
76newKeyboard = const False
77
78-- | Get the keyboard.
79getKeyboard :: IO Keyboard
80getKeyboard =
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'.
95newMouse :: Mouse
96newMouse = Mouse (const False) (const 0)
97
98-- | Get the mouse.
99--
100-- The previous mouse state is required to compute position deltas.
101getMouse :: Mouse -> IO Mouse
102getMouse 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.
134newInput :: Input
135newInput = Input newKeyboard newMouse
136
137-- | Get input devices.
138getInput :: Input -> IO Input
139getInput (Input _ oldMouse) = do
140 keyboard <- getKeyboard
141 mouse <- getMouse oldMouse
142 return $ Input keyboard mouse
143
144-- | Poll input devices.
145pollInput :: IO ()
146pollInput = GLFW.pollEvents
147
148-- | Return a mouse that reacts to button toggles.
149toggledMouse :: Mouse -- ^ Previous mouse state.
150 -> Mouse -- ^ Current mouse state.
151 -> Mouse -- ^ Toggled mouse.
152
153toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) }
154
155-- | Return a keyboard that reacts to key toggles.
156toggledKeyboard :: Keyboard -- ^ Previous keyboard state.
157 -> Keyboard -- ^ Current keyboard state.
158 -> Keyboard -- ^ Toggled keyboard.
159
160toggledKeyboard prev cur key = cur key && not (prev key)
161
162-- | Delay configuration for each mouse button.
163type ButtonDelay = MouseButton -> Float
164
165
166-- | Accumulated delays for each mouse button.
167data DelayedMouse = DelayedMouse
168 { delayedMouse :: Mouse
169 , delay :: ButtonDelay
170 , accum :: V.Vector Float
171 }
172
173newDM :: ButtonDelay -- ^ Delay configuration for each button.
174 -> DelayedMouse
175newDM delay = DelayedMouse newMouse delay $
176 V.replicate (fromEnum (maxBound :: MouseButton)) 0
177
178updateDM :: DelayedMouse -- ^ Current mouse state.
179 -> Float -- ^ Time elapsed since last udpate.
180 -> DelayedMouse
181
182updateDM (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.
194setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse
195setMousePosition (x,y) mouse = do
196 GLFW.mousePos $= Position (fromIntegral x) (fromIntegral y)
197 getMouse mouse
198
199-- | Set the mouse wheel.
200setMouseWheel :: Integral a => a -> Mouse -> IO Mouse
201setMouseWheel w mouse = do
202 GLFW.mouseWheel $= (fromIntegral w)
203 getMouse mouse
204
205toGLFWkey :: Key -> Int
206toGLFWkey KEY_A = ord 'A'
207toGLFWkey KEY_B = ord 'B'
208toGLFWkey KEY_C = ord 'C'
209toGLFWkey KEY_D = ord 'D'
210toGLFWkey KEY_E = ord 'E'
211toGLFWkey KEY_F = ord 'F'
212toGLFWkey KEY_G = ord 'G'
213toGLFWkey KEY_H = ord 'H'
214toGLFWkey KEY_I = ord 'I'
215toGLFWkey KEY_J = ord 'J'
216toGLFWkey KEY_K = ord 'K'
217toGLFWkey KEY_L = ord 'L'
218toGLFWkey KEY_M = ord 'M'
219toGLFWkey KEY_N = ord 'N'
220toGLFWkey KEY_O = ord 'O'
221toGLFWkey KEY_P = ord 'P'
222toGLFWkey KEY_Q = ord 'Q'
223toGLFWkey KEY_R = ord 'R'
224toGLFWkey KEY_S = ord 'S'
225toGLFWkey KEY_T = ord 'T'
226toGLFWkey KEY_U = ord 'U'
227toGLFWkey KEY_V = ord 'V'
228toGLFWkey KEY_W = ord 'W'
229toGLFWkey KEY_X = ord 'X'
230toGLFWkey KEY_Y = ord 'Y'
231toGLFWkey KEY_Z = ord 'Z'
232toGLFWkey KEY_0 = ord '0'
233toGLFWkey KEY_1 = ord '1'
234toGLFWkey KEY_2 = ord '2'
235toGLFWkey KEY_3 = ord '3'
236toGLFWkey KEY_4 = ord '4'
237toGLFWkey KEY_5 = ord '5'
238toGLFWkey KEY_6 = ord '6'
239toGLFWkey KEY_7 = ord '7'
240toGLFWkey KEY_8 = ord '8'
241toGLFWkey KEY_9 = ord '9'
242toGLFWkey KEY_F1 = fromEnum GLFW.F1
243toGLFWkey KEY_F2 = fromEnum GLFW.F2
244toGLFWkey KEY_F3 = fromEnum GLFW.F3
245toGLFWkey KEY_F4 = fromEnum GLFW.F4
246toGLFWkey KEY_F5 = fromEnum GLFW.F5
247toGLFWkey KEY_F6 = fromEnum GLFW.F6
248toGLFWkey KEY_F7 = fromEnum GLFW.F7
249toGLFWkey KEY_F8 = fromEnum GLFW.F8
250toGLFWkey KEY_F9 = fromEnum GLFW.F9
251toGLFWkey KEY_F10 = fromEnum GLFW.F10
252toGLFWkey KEY_F11 = fromEnum GLFW.F11
253toGLFWkey KEY_F12 = fromEnum GLFW.F12
254toGLFWkey KEY_ESC = fromEnum GLFW.ESC
255toGLFWkey KEY_SPACE = ord ' '
256toGLFWkey KEY_UP = fromEnum GLFW.UP
257toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN
258toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT
259toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT
260
261
262toGLFWbutton :: MouseButton -> GLFW.MouseButton
263toGLFWbutton LMB = GLFW.ButtonLeft
264toGLFWbutton RMB = GLFW.ButtonRight
265toGLFWbutton 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
83runGame :: Game s a -> s -> IO (Either String (a,s)) 84runGame :: Game s a -> s -> IO (Either String (a,s))
84runGame game state = runErrorT . R.runResourceT . runStateT game $ state 85runGame game state = runErrorT . R.runResourceT . runStateT game $ state
85 86
87-- | Run the given game and discard its state.
88runGame' :: Game s a -> s -> IO (Either String a)
89runGame' 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.
87runSubGame :: Game s a -> s -> Game t (a,s) 94runSubGame :: Game s a -> s -> Game t (a,s)
88runSubGame game state = gameIO (runGame game state) >>= \result -> case result of 95runSubGame 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
14import Data.List (foldl') 14import Data.List (foldl')
15 15
16-- | An axis-aligned bounding box in 2D space. 16-- | An axis-aligned bounding box in 2D space.
17data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 17data 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.
20data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 20data 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.
23aabb2 :: [Vector2] -> AABB2 23aabb2 :: [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 @@
1module Spear.Math.Entity
2(
3 Entity(..)
4)
5where
6
7
8import qualified Spear.Math.Matrix3 as M
9import qualified Spear.Math.Spatial2 as S
10import qualified Spear.Math.Vector as V
11
12
13-- | An entity in 2D space.
14newtype Entity = Entity { transform :: M.Matrix3 }
15
16
17instance 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)
12where 12where
13 13
14
15import Spear.Math.Camera as Cam 14import Spear.Math.Camera as Cam
16import Spear.Math.Matrix3 as M3 15import Spear.Math.Matrix3 as M3
17import Spear.Math.Matrix4 as M4 16import Spear.Math.Matrix4 as M4
18import Spear.Math.Spatial3 as S 17import Spear.Math.Spatial3 as S
19import Spear.Math.Vector as V 18import 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.
23fastNormalMatrix :: Matrix4 -> Matrix3 21fastNormalMatrix :: Matrix4 -> Matrix3
24fastNormalMatrix m = 22fastNormalMatrix 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.
33unproject :: Matrix4 -- ^ Inverse projection matrix 30unproject :: 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.
77rpgTransform 72rpgTransform
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.
102pltTransform :: Matrix3 -> Matrix4 96pltTransform :: Matrix3 -> Matrix4
103pltTransform mat = 97pltTransform 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
127rpgInverse h a axis pos viewI = 120rpgInverse 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 =
138pltInverse :: Matrix3 -> Matrix4 130pltInverse :: Matrix3 -> Matrix4
139pltInverse = M4.inverseTransform . pltTransform 131pltInverse = 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.
143objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 134objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2
144objToClip cam model p = 135objToClip 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 @@
1module Spear.Math.Spatial2 1module 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)
2where 28where
3 29
4
5import Spear.Math.Vector 30import Spear.Math.Vector
6import Spear.Math.Matrix3 as M 31import qualified Spear.Math.Matrix3 as M
7 32
33type Angle = Float
34type 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.
10class Spatial2 s where 37class 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 46move :: Spatial2 s => Vector2 -> s -> s
20 47move 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 50moveFwd :: Spatial2 s => Float -> s -> s
24 -- | Make the spatial Strafe right. 51moveFwd 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. 54moveBack :: Spatial2 s => Float -> s -> s
28 rotate :: Float -> s -> s 55moveBack 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 58moveUp :: Spatial2 s => Float -> s -> s
32 59moveUp 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 62moveDown :: Spatial2 s => Float -> s -> s
36 -- | Get the spatial's forward vector. 63moveDown 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. 66moveLeft :: Spatial2 s => Float -> s -> s
40 up :: s -> Vector2 67moveLeft 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 70moveRight :: Spatial2 s => Float -> s -> s
44 71moveRight 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 74rotate :: Spatial2 s => Float -> s -> s
48 -- | Set the spatial's transform. 75rotate 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. 81setRotation :: Spatial2 s => Float -> s -> s
55 lookAt :: Vector2 -> s -> s 82setRotation 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 87rotate' :: Float -> Vector2 -> Vector2
61 setTransform (M.transform r fwd position) s 88rotate' 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 91pos :: Spatial2 s => s -> Vector2
65 -> Float -- ^ Angle 92pos = p . getObj2
66 -> Float -- ^ Orbit radius 93
67 -> s 94-- | Get the spatial's forward vector.
68 -> s 95fwd :: Spatial2 s => s -> Vector2
69 96fwd = 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 99up :: Spatial2 s => s -> Vector2
73 py = (y pt) + radius * cos a 100up = u . getObj2
74 in 101
75 setPos (vec2 px py) s 102-- | Get the spatial's right vector.
103right :: Spatial2 s => s -> Vector2
104right = r . getObj2
105
106-- | Get the spatial's transform.
107transform :: Spatial2 s => s -> M.Matrix3
108transform s = let o = getObj2 s in M.transform (r o) (u o) (p o)
109
110-- | Set the spatial's transform.
111setTransform :: Spatial2 s => M.Matrix3 -> s -> s
112setTransform 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.
117setPos :: Spatial2 s => Vector2 -> s -> s
118setPos pos s = setObj2 s $ (getObj2 s) { p = pos }
119
120-- | Make the spatial look at the given point.
121lookAt :: Spatial2 s => Vector2 -> s -> s
122lookAt 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
129orbit :: Spatial2 s => Vector2 -> Angle -> Radius -> s -> s
130orbit 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.
137data Obj2 = Obj2
138 { r :: Vector2
139 , u :: Vector2
140 , p :: Vector2
141 } deriving Show
142
143instance Spatial2 Obj2 where
144 getObj2 = id
145 setObj2 _ o' = o'
146
147obj2FromVectors :: Right2 -> Up2 -> Position2 -> Obj2
148obj2FromVectors = Obj2
149
150obj2FromTransform :: M.Matrix3 -> Obj2
151obj2FromTransform 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
13type Matrix4 = M.Matrix4 31type Matrix4 = M.Matrix4
14 32
15class Spatial3 s where 33class 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 } 42move :: Spatial3 s => Vector3 -> s -> s
25 43move 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) } 46moveFwd :: Spatial3 s => Float -> s -> s
29 47moveFwd 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) } 50moveBack :: Spatial3 s => Float -> s -> s
33 51moveBack 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) } 54moveLeft :: Spatial3 s => Float -> s -> s
37 55moveLeft 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) } 58moveRight :: Spatial3 s => Float -> s -> s
41 59moveRight 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 = 62rotate :: Spatial3 s => Vector3 -> Float -> s -> s
45 let t = transform s 63rotate 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 = 69pitch :: Spatial3 s => Float -> s -> s
52 let o = getObj3 s 70pitch 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 = 80yaw :: Spatial3 s => Float -> s -> s
63 let o = getObj3 s 81yaw 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 = 91roll :: Spatial3 s => Float -> s -> s
74 let o = getObj3 s 92roll 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 102pos :: Spatial3 s => s -> Vector3
85 103pos = 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 106fwd :: Spatial3 s => s -> Vector3
89 107fwd = 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 110up :: Spatial3 s => s -> Vector3
93 111up = 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 114right :: Spatial3 s => s -> Vector3
97 115right = 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) 118transform :: Spatial3 s => s -> Matrix4
101 119transform 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 = 122setTransform :: Spatial3 s => Matrix4 -> s -> s
105 let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) 123setTransform 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 } 128setPos :: Spatial3 s => Vector3 -> s -> s
111 129setPos 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 = 132lookAt :: Spatial3 s => Vector3 -> s -> s
115 let position = pos s 133lookAt 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 141orbit :: 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 149orbit 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.
144data Obj3 = Obj3 162data 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 @@
1module Spear.Math.Vector.Vector2 1module 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)
12where 15where
13 16
14
15import Spear.Math.Vector.Class 17import Spear.Math.Vector.Class
16 18
17
18import Foreign.C.Types (CFloat) 19import Foreign.C.Types (CFloat)
19import Foreign.Storable 20import Foreign.Storable
20 21
22type Right2 = Vector2
23type Up2 = Vector2
24type Position2 = Vector2
21 25
22-- | Represents a vector in 2D. 26-- | Represents a vector in 2D.
23data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) 27data 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
35instance Fractional Vector2 where 39instance 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
40instance Ord Vector2 where 44instance 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)
89instance Storable Vector2 where 93instance 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)
129perp :: Vector2 -> Vector2 133perp :: Vector2 -> Vector2
130perp (Vector2 x y) = Vector2 y (-x) 134perp (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 @@
1module Spear.Math.Vector.Vector3 1module 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 @@
1module Spear.Math.Vector.Vector4 1module 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
39instance Fractional Vector4 where 39instance 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
44instance Ord Vector4 where 44instance 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)
124instance Storable Vector4 where 124instance 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 @@
1module 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)
31where
32
33
34import Spear.GL
35import Spear.Math.AABB
36import qualified Spear.Math.Camera as Cam
37import Spear.Math.Collision as Col
38import qualified Spear.Math.Matrix3 as M3
39import qualified Spear.Math.Matrix4 as M4
40import Spear.Math.MatrixUtils
41import qualified Spear.Math.Spatial2 as S2
42import qualified Spear.Math.Spatial3 as S3
43import Spear.Math.Utils
44import Spear.Math.Vector
45import qualified Spear.Render.AnimatedModel as AM
46import Spear.Render.Program
47import Spear.Render.StaticModel as SM
48
49import Data.Fixed (mod')
50import Data.List (foldl')
51
52
53-- | Game style.
54data GameStyle
55 = RPG -- ^ RPG or RTS style game.
56 | PLT -- ^ Platformer or space invaders style game.
57
58
59data 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
69dummyWindow = Window M4.id M4.id 0 0 640 480
70
71
72-- | An object in the game scene.
73data 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
84instance 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.
171goNew :: GameStyle
172 -> Either StaticModelResource AM.AnimatedModelResource
173 -> [Collisioner2]
174 -> M3.Matrix3 -- ^ Transform
175 -> Vector3 -- ^ Axis of rotation
176 -> GameObject
177
178goNew style (Left smr) cols transf axis = GameObject
179 style (Left $ SM.staticModelRenderer smr) cols transf axis 0 dummyWindow
180
181goNew style (Right amr) cols transf axis = GameObject
182 style (Right $ AM.animatedModelRenderer 1 amr) cols transf axis 0 dummyWindow
183
184
185goUpdate :: Float -> GameObject -> GameObject
186goUpdate 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.
207goRPGtransform :: GameObject -> M4.Matrix4
208goRPGtransform 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.
214currentAnimation :: Enum a => GameObject -> a
215currentAnimation 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.
221numCollisioners :: GameObject -> Int
222numCollisioners = length . collisioners
223
224
225-- | Set the game object's current animation.
226setAnimation :: Enum a => a -> GameObject -> GameObject
227setAnimation 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.
233setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject
234setAnimationSpeed 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.
240setAxis :: Vector3 -> GameObject -> GameObject
241setAxis ax go = go { axis = ax }
242
243
244-- | Set the game object's collisioners.
245setCollisioners :: [Collisioner2] -> GameObject -> GameObject
246setCollisioners cols go = go { collisioners = cols }
247
248
249-- | Set the game object's window.
250setWindow :: Window -> GameObject -> GameObject
251setWindow wnd go = go { window = wnd }
252
253
254-- | Manipulate the game object's collisioners.
255withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject
256withCollisioners go f = go { collisioners = f $ collisioners go }
257
258
259-- | Render the game object.
260goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO ()
261goRender 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
283type Bind = IO ()
284
285type Render = IO ()
286
287
288goRender' :: (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 ()
300goRender' 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.
312goCollide :: GameObject -> GameObject -> Bool
313goCollide 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 @@
1module Spear.Scene.Light
2(
3 Light(..)
4)
5where
6
7
8import qualified Spear.Math.Matrix4 as M
9import qualified Spear.Math.Spatial3 as S
10import Spear.Math.Vector
11
12
13data 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 @@
1module Spear.Scene.Loader 1module 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
29import Spear.Render.Material 26import Spear.Render.Material
30import Spear.Render.Program 27import Spear.Render.Program
31import Spear.Render.StaticModel as SM 28import Spear.Render.StaticModel as SM
32import Spear.Scene.GameObject as GO
33import Spear.Scene.Graph 29import Spear.Scene.Graph
34import Spear.Scene.Light
35import Spear.Scene.SceneResources 30import Spear.Scene.SceneResources
36 31
37import Control.Monad.State.Strict 32import 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
74resourceMap' node@(SceneNode nid props children) = do 68resourceMap' node@(SceneNode nid props children) = do
@@ -296,73 +290,6 @@ loadShader shaderType ((stype, file):xs) =
296loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader 290loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader
297loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file 291loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file
298 292
299newLight :: SceneGraph -> Loader ()
300newLight _ = return ()
301
302--------------------
303-- Object Loading --
304--------------------
305
306loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject
307loadGO 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
324type 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'.
332loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a]
333loadObjects 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.
339newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a]
340newObject newGO sceneRes (SceneNode nid props children) =
341 let o = newObject' newGO sceneRes nid props
342 in o : (concat $ fmap (newObject newGO sceneRes) children)
343
344newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props]
345
346newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a
347newObject' 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
361vectors :: Maybe Vector2 -> (Vector2, Vector2)
362vectors 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
24import Spear.Render.Material 24import Spear.Render.Material
25import Spear.Render.Program 25import Spear.Render.Program
26import Spear.Render.StaticModel 26import Spear.Render.StaticModel
27import Spear.Scene.Light
28 27
29import Data.Map as M 28import 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'.
43emptySceneResources = 41emptySceneResources =
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.
47getShader :: SceneResources -> String -> Maybe GLSLShader 45getShader :: 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 #-}
2module Spear.Sys.Timer 2module 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 @@
1module 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)
30where
31
32import Spear.Game
33import Spear.Sys.Timer as Timer
34
35import Data.Char (ord)
36import Control.Concurrent.MVar
37import Control.Monad (when)
38import Control.Monad.IO.Class
39import qualified Graphics.UI.GLFW as GLFW
40import Graphics.UI.GLFW (DisplayBits(..), WindowMode(..))
41import qualified Graphics.Rendering.OpenGL as GL
42
43type Width = Int
44type Height = Int
45
46-- | Window dimensions.
47type Dimensions = (Width, Height)
48
49-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor).
50type Context = (Int, Int)
51
52type WindowTitle = String
53
54type CloseRequest = MVar Bool
55
56-- | A window.
57data Window = Window
58 { closeRequest :: CloseRequest
59 , inputEvents :: MVar [InputEvent]
60 }
61
62-- | Poll the window's events.
63events :: MonadIO m => Window -> m [InputEvent]
64events 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.
72type Init s = Window -> Game () s
73
74withWindow :: MonadIO m
75 => Dimensions -> [DisplayBits] -> WindowMode -> Context
76 -> Maybe WindowTitle
77 -> Init s
78 -> (Window -> Game s a)
79 -> m (Either String a)
80withWindow 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
90setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle
91 -> Game s Window
92setup (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
117defaultBits [] = [DisplayRGBBits 8 8 8]
118defaultBits xs = xs
119
120compat (major, minor)
121 | major >= 3 = GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCompatProfile
122 | otherwise = return ()
123
124glfwInit :: Game s ()
125glfwInit = 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.
132type Dt = Float
133
134-- | Return true if the application should continue running, false otherwise.
135type Step s = Dt -> Game s (Bool)
136
137-- | Maximum frame rate.
138type FrameCap = Int
139
140-- | Run the application's main loop.
141loop :: Maybe FrameCap -> Step s -> Window -> Game s ()
142loop (Just maxFPS) step wnd = loopCapped maxFPS step wnd
143loop Nothing step wnd = do
144 timer <- gameIO $ start newTimer
145 run (closeRequest wnd) timer step
146 return ()
147
148run :: CloseRequest -> Timer -> Step s -> Game s ()
149run 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
155loopCapped :: Int -> Step s -> Window -> Game s ()
156loopCapped 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
164runCapped :: CloseRequest -> Float -> Timer -> Timer -> Step s -> Game s ()
165runCapped 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
176getRequest :: MVar Bool -> IO Bool
177getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of
178 Nothing -> False
179 Just x -> x
180
181onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback
182onWindowClose closeRequest = putMVar closeRequest True >> return False
183
184onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback
185onResize es (GL.Size w h) = addEvent es $ Resize (fromIntegral w) (fromIntegral h)
186
187onKey :: MVar [InputEvent] -> GLFW.KeyCallback
188onKey es key GLFW.Press = addEvent es $ KeyDown (fromGLFWkey key)
189onKey es key GLFW.Release = addEvent es $ KeyUp (fromGLFWkey key)
190
191onChar :: MVar [InputEvent] -> GLFW.CharCallback
192onChar es c GLFW.Press = addEvent es $ KeyDown (fromGLFWkey (GLFW.CharKey c))
193onChar es c GLFW.Release = addEvent es $ KeyUp (fromGLFWkey (GLFW.CharKey c))
194
195onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback
196onMouseButton es bt GLFW.Press = addEvent es $ MouseDown (fromGLFWbutton bt)
197onMouseButton es bt GLFW.Release = addEvent es $ MouseUp (fromGLFWbutton bt)
198
199onMouseMove :: MVar [InputEvent] -> IO GLFW.MousePosCallback
200onMouseMove es = newEmptyMVar >>= return . flip onMouseMove' es
201
202onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.MousePosCallback
203onMouseMove' 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
212replaceMVar :: MVar a -> a -> IO ()
213replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val
214
215addEvent :: MVar [a] -> a -> IO ()
216addEvent mvar val = tryTakeMVar mvar >>= \xs -> case xs of
217 Nothing -> putMVar mvar [val]
218 Just es -> putMVar mvar (val:es)
219
220-- Input
221
222data 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
231data 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
242data MouseButton = LMB | RMB | MMB
243 deriving (Eq, Enum, Bounded, Show)
244
245data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta
246 deriving (Eq, Enum, Bounded, Show)
247
248type MousePos = (Int,Int)
249type MouseDelta = (Int,Int)
250
251fromGLFWkey :: GLFW.Key -> Key
252fromGLFWkey (GLFW.CharKey 'A') = KEY_A
253fromGLFWkey (GLFW.CharKey 'B') = KEY_B
254fromGLFWkey (GLFW.CharKey 'C') = KEY_C
255fromGLFWkey (GLFW.CharKey 'D') = KEY_D
256fromGLFWkey (GLFW.CharKey 'E') = KEY_E
257fromGLFWkey (GLFW.CharKey 'F') = KEY_F
258fromGLFWkey (GLFW.CharKey 'G') = KEY_G
259fromGLFWkey (GLFW.CharKey 'H') = KEY_H
260fromGLFWkey (GLFW.CharKey 'I') = KEY_I
261fromGLFWkey (GLFW.CharKey 'J') = KEY_J
262fromGLFWkey (GLFW.CharKey 'K') = KEY_K
263fromGLFWkey (GLFW.CharKey 'L') = KEY_L
264fromGLFWkey (GLFW.CharKey 'M') = KEY_M
265fromGLFWkey (GLFW.CharKey 'N') = KEY_N
266fromGLFWkey (GLFW.CharKey 'O') = KEY_O
267fromGLFWkey (GLFW.CharKey 'P') = KEY_P
268fromGLFWkey (GLFW.CharKey 'Q') = KEY_Q
269fromGLFWkey (GLFW.CharKey 'R') = KEY_R
270fromGLFWkey (GLFW.CharKey 'S') = KEY_S
271fromGLFWkey (GLFW.CharKey 'T') = KEY_T
272fromGLFWkey (GLFW.CharKey 'U') = KEY_U
273fromGLFWkey (GLFW.CharKey 'V') = KEY_V
274fromGLFWkey (GLFW.CharKey 'W') = KEY_W
275fromGLFWkey (GLFW.CharKey 'X') = KEY_X
276fromGLFWkey (GLFW.CharKey 'Y') = KEY_Y
277fromGLFWkey (GLFW.CharKey 'Z') = KEY_Z
278fromGLFWkey (GLFW.CharKey '0') = KEY_0
279fromGLFWkey (GLFW.CharKey '1') = KEY_1
280fromGLFWkey (GLFW.CharKey '2') = KEY_2
281fromGLFWkey (GLFW.CharKey '3') = KEY_3
282fromGLFWkey (GLFW.CharKey '4') = KEY_4
283fromGLFWkey (GLFW.CharKey '5') = KEY_5
284fromGLFWkey (GLFW.CharKey '6') = KEY_6
285fromGLFWkey (GLFW.CharKey '7') = KEY_7
286fromGLFWkey (GLFW.CharKey '8') = KEY_8
287fromGLFWkey (GLFW.CharKey '9') = KEY_9
288fromGLFWkey (GLFW.CharKey ' ') = KEY_SPACE
289fromGLFWkey (GLFW.SpecialKey GLFW.F1) = KEY_F1
290fromGLFWkey (GLFW.SpecialKey GLFW.F2) = KEY_F2
291fromGLFWkey (GLFW.SpecialKey GLFW.F3) = KEY_F3
292fromGLFWkey (GLFW.SpecialKey GLFW.F4) = KEY_F4
293fromGLFWkey (GLFW.SpecialKey GLFW.F5) = KEY_F5
294fromGLFWkey (GLFW.SpecialKey GLFW.F6) = KEY_F6
295fromGLFWkey (GLFW.SpecialKey GLFW.F7) = KEY_F7
296fromGLFWkey (GLFW.SpecialKey GLFW.F8) = KEY_F8
297fromGLFWkey (GLFW.SpecialKey GLFW.F9) = KEY_F9
298fromGLFWkey (GLFW.SpecialKey GLFW.F10) = KEY_F10
299fromGLFWkey (GLFW.SpecialKey GLFW.F11) = KEY_F11
300fromGLFWkey (GLFW.SpecialKey GLFW.F12) = KEY_F12
301fromGLFWkey (GLFW.SpecialKey GLFW.ESC) = KEY_ESC
302fromGLFWkey (GLFW.SpecialKey GLFW.UP) = KEY_UP
303fromGLFWkey (GLFW.SpecialKey GLFW.DOWN) = KEY_DOWN
304fromGLFWkey (GLFW.SpecialKey GLFW.LEFT) = KEY_LEFT
305fromGLFWkey (GLFW.SpecialKey GLFW.RIGHT) = KEY_RIGHT
306fromGLFWkey _ = KEY_UNKNOWN
307
308fromGLFWbutton :: GLFW.MouseButton -> MouseButton
309fromGLFWbutton GLFW.ButtonLeft = LMB
310fromGLFWbutton GLFW.ButtonRight = RMB
311fromGLFWbutton 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 @@
1Copyright (c) 2013, Marc Sunet
2
3All rights reserved.
4
5Redistribution and use in source and binary forms, with or without
6modification, 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
20THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30OF 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 @@
1module Main where
2
3import Pong
4
5import Spear.Math.AABB
6import Spear.Math.Spatial2
7import Spear.Math.Vector
8import Spear.Game
9import Spear.Window
10
11import Data.Maybe (mapMaybe)
12import qualified Graphics.Rendering.OpenGL.GL as GL
13import Graphics.Rendering.OpenGL.GL (($=))
14
15data GameState = GameState
16 { wnd :: Window
17 , elapsed :: Double
18 , world :: [GameObject]
19 }
20
21main = do
22 result <- run
23 case result of
24 Left err -> putStrLn err
25 Right _ -> return ()
26
27run = withWindow (640,480) [] Window (2,0) (Just "Pong") initGame
28 $ loop (Just 30) step
29
30initGame 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
37step :: Dt -> Game GameState Bool
38step 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
49render world = do
50 GL.clear [GL.ColorBuffer]
51 mapM_ renderGO world
52 swapBuffers
53
54renderGO :: GameObject -> IO ()
55renderGO 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
67process = mapM_ procEvent
68procEvent (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
74procEvent _ = return ()
75
76translate = mapMaybe translate'
77translate' (KeyDown KEY_LEFT) = Just MoveLeft
78translate' (KeyDown KEY_RIGHT) = Just MoveRight
79translate' (KeyUp KEY_LEFT) = Just StopLeft
80translate' (KeyUp KEY_RIGHT) = Just StopRight
81translate' _ = Nothing
82
83exitRequested = any (==(KeyDown KEY_ESC))
84
85f2d :: Float -> GL.GLdouble
86f2d = 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 @@
1module Pong
2(
3 GameEvent(..)
4, GameObject
5, newWorld
6, stepWorld
7, aabb
8)
9where
10
11import Spear.Math.AABB
12import Spear.Math.Spatial2
13import Spear.Math.Vector
14
15import Data.List (foldl')
16import Data.Monoid
17import GHC.Float (double2Float)
18
19type Elapsed = Double
20type Dt = Float
21
22-- Step function
23
24data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) }
25
26sid :: Step a a
27sid = Step $ \_ _ a -> (a, sid)
28
29spure :: (a -> b) -> Step a b
30spure f = Step $ \_ _ x -> (f x, spure f)
31
32smap :: (a -> b) -> Step c a -> Step c b
33smap 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
46sfst :: Step (a,b) a
47sfst = spure $ \(a,_) -> a
48
49ssnd :: Step (a,b) b
50ssnd = spure $ \(_,b) -> b
51
52-- Game events
53
54data GameEvent
55 = MoveLeft
56 | MoveRight
57 | StopLeft
58 | StopRight
59 deriving Eq
60
61-- Game objects
62
63data GameObject = GameObject
64 { aabb :: AABB2
65 , obj :: Obj2
66 , gostep :: Step ([GameEvent], [GameObject], GameObject) GameObject
67 }
68
69instance Spatial2 GameObject where
70 getObj2 = obj
71 setObj2 s o = s { obj = o }
72
73stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
74stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
75
76update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
77update elapsed dt evts gos go =
78 let (go', s') = step (gostep go) elapsed dt (evts, gos, go)
79 in go' { gostep = s' }
80
81ballBox :: AABB2
82ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01
83
84padSize = vec2 0.05 0.02
85
86padBox = AABB2 (-padSize) padSize
87
88obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
89
90ballVelocity = Vector2 0.3 0.3
91
92newWorld =
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
100ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject
101ignore = spure $ \(_,_,go) -> go
102
103ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject)
104ignoreEvts = spure $ \(_, world, go) -> (world, go)
105
106ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject)
107ignoreGOs = spure $ \(evts, _, go) -> (evts, go)
108
109-- Ball steppers
110
111stepBall vel = ignoreEvts .> collideBall vel .> moveBall
112
113collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject)
114collideBall 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
124collide 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
132aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax)
133
134moveBall :: Step (Vector2, GameObject) GameObject
135moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall)
136
137-- Enemy stepper
138
139stepEnemy = ignore .> movePad
140
141movePad :: Step GameObject GameObject
142movePad = 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
151stepPlayer = ignoreGOs
152 .> moveGO False MoveLeft StopLeft
153 .> moveGO False MoveRight StopRight
154 .> ssnd
155 .> clamp
156
157moveGO :: Bool -> GameEvent -> GameEvent
158 -> Step ([GameEvent], GameObject) ([GameEvent], GameObject)
159moveGO 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
164clamp :: Step GameObject GameObject
165clamp = 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
172toDir True MoveLeft = vec2 (-1) 0
173toDir True MoveRight = vec2 1 0
174toDir _ _ = 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 @@
1import Distribution.Simple
2main = 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
4name: pong
5version: 0.1.0.0
6synopsis: A pong clone
7-- description:
8license: BSD3
9license-file: LICENSE
10author: Marc Sunet
11-- maintainer:
12-- copyright:
13category: Game
14build-type: Simple
15cabal-version: >=1.8
16
17executable pong
18 -- hs-source-dirs: src
19 main-is: Main.hs
20 -- other-modules:
21 build-depends: base ==4.6.*, Spear, OpenGL
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-27 15:58:35 +0000