diff options
73 files changed, 9017 insertions, 9164 deletions
@@ -1,7 +1,7 @@ | |||
1 | Copyright (c) 2012 Marc Sunet | 1 | Copyright (c) 2012 Marc Sunet |
2 | 2 | ||
3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: |
4 | 4 | ||
5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. |
6 | 6 | ||
7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
@@ -1,48 +1,48 @@ | |||
1 | Spear | 1 | Spear |
2 | ===== | 2 | ===== |
3 | 3 | ||
4 | Spear is a simple 2.5D game engine I have been working on since I started learning Haskell. | 4 | Spear is a simple 2.5D game engine I have been working on since I started learning Haskell. |
5 | The project's goal is to put what I learn into practise, to explore how far I can get with Haskell and if the results | 5 | The project's goal is to put what I learn into practise, to explore how far I can get with Haskell and if the results |
6 | are decent enough, to build one or two game demos along the way. | 6 | are decent enough, to build one or two game demos along the way. |
7 | 7 | ||
8 | Installation | 8 | Installation |
9 | ------------ | 9 | ------------ |
10 | 10 | ||
11 | Simply clone the repo and build with cabal: | 11 | Simply clone the repo and build with cabal: |
12 | 12 | ||
13 | ``` | 13 | ``` |
14 | $ git clone https://github.com/jeannekamikaze/Spear.git | 14 | $ git clone https://github.com/jeannekamikaze/Spear.git |
15 | $ cd Spear | 15 | $ cd Spear |
16 | $ cabal install | 16 | $ cabal install |
17 | ``` | 17 | ``` |
18 | 18 | ||
19 | Features | 19 | Features |
20 | -------- | 20 | -------- |
21 | 21 | ||
22 | ### Application and Input | 22 | ### Application and Input |
23 | * Easy way to set up a window with the desired OpenGL context version. | 23 | * Easy way to set up a window with the desired OpenGL context version. |
24 | * Raw polled, toggled and delayed input. | 24 | * Raw polled, toggled and delayed input. |
25 | * High resolution timer. | 25 | * High resolution timer. |
26 | 26 | ||
27 | ### Assets | 27 | ### Assets |
28 | * MD2 and OBJ model loaders. | 28 | * MD2 and OBJ model loaders. |
29 | * BMP image loader. | 29 | * BMP image loader. |
30 | * Assets backed up by Resource for automatic (and optionally, manual) deletion. | 30 | * Assets backed up by Resource for automatic (and optionally, manual) deletion. |
31 | 31 | ||
32 | ### Collision | 32 | ### Collision |
33 | * Simple collision library featuring AABBs and bounding circles. | 33 | * Simple collision library featuring AABBs and bounding circles. |
34 | 34 | ||
35 | ### OpenGL | 35 | ### OpenGL |
36 | * OpenGL >=3 wrapper library. | 36 | * OpenGL >=3 wrapper library. |
37 | * OpenGL resources (VAOs, buffers, textures, etc.) backed up by Resource for automatic (and optionally, manual) deletion. | 37 | * OpenGL resources (VAOs, buffers, textures, etc.) backed up by Resource for automatic (and optionally, manual) deletion. |
38 | 38 | ||
39 | ### Math | 39 | ### Math |
40 | * Vectors, matrices, quaternions, cameras, segments, rays, etc. | 40 | * Vectors, matrices, quaternions, cameras, segments, rays, etc. |
41 | * The Spatial2 and Spatial3 type classes for objects that can be moved around in 2D and 3D space, respectively. | 41 | * The Spatial2 and Spatial3 type classes for objects that can be moved around in 2D and 3D space, respectively. |
42 | 42 | ||
43 | ### Render | 43 | ### Render |
44 | * Static and vertex-animated model resources, compiled into a VAO for efficient rendering. | 44 | * Static and vertex-animated model resources, compiled into a VAO for efficient rendering. |
45 | * Static and vertex-animated model renderers. Vertex animation is done in a vertex shader. | 45 | * Static and vertex-animated model renderers. Vertex animation is done in a vertex shader. |
46 | 46 | ||
47 | ### Scene | 47 | ### Scene |
48 | * Automated loading of scenes and scene resources as described by scene files. | 48 | * Automated loading of scenes and scene resources as described by scene files. |
@@ -1,2 +1,2 @@ | |||
1 | import Distribution.Simple | 1 | import Distribution.Simple |
2 | main = defaultMain | 2 | main = defaultMain |
diff --git a/Spear.cabal b/Spear.cabal index e25b347..0e52faf 100644 --- a/Spear.cabal +++ b/Spear.cabal | |||
@@ -1,108 +1,108 @@ | |||
1 | name: Spear | 1 | name: Spear |
2 | version: 0.1 | 2 | version: 0.1 |
3 | cabal-version: >=1.2 | 3 | cabal-version: >=1.2 |
4 | build-type: Simple | 4 | build-type: Simple |
5 | license: BSD3 | 5 | license: BSD3 |
6 | license-file: LICENSE | 6 | license-file: LICENSE |
7 | maintainer: jeannekamikaze@gmail.com | 7 | maintainer: jeannekamikaze@gmail.com |
8 | homepage: http://spear.shellblade.net | 8 | homepage: http://spear.shellblade.net |
9 | synopsis: A 2.5D game framework. | 9 | synopsis: A 2.5D game framework. |
10 | category: Game | 10 | category: Game |
11 | author: Marc Sunet | 11 | author: Marc Sunet |
12 | data-dir: "" | 12 | data-dir: "" |
13 | 13 | ||
14 | library | 14 | library |
15 | build-depends: GLFW -any, | 15 | build-depends: GLFW -any, |
16 | OpenGL -any, | 16 | OpenGL -any, |
17 | OpenGLRaw -any, | 17 | OpenGLRaw -any, |
18 | StateVar -any, | 18 | StateVar -any, |
19 | base -any, | 19 | base -any, |
20 | bytestring >= 0.10, | 20 | bytestring >= 0.10, |
21 | directory -any, | 21 | directory -any, |
22 | mtl -any, | 22 | mtl -any, |
23 | transformers -any, | 23 | transformers -any, |
24 | resourcet -any, | 24 | resourcet -any, |
25 | parsec >= 3, | 25 | parsec >= 3, |
26 | containers -any, | 26 | containers -any, |
27 | vector -any, | 27 | vector -any, |
28 | array -any | 28 | array -any |
29 | 29 | ||
30 | exposed-modules: Spear.App | 30 | exposed-modules: Spear.App |
31 | Spear.App.Application | 31 | Spear.App.Application |
32 | Spear.App.Input | 32 | Spear.App.Input |
33 | Spear.Assets.Image | 33 | Spear.Assets.Image |
34 | Spear.Assets.Model | 34 | Spear.Assets.Model |
35 | Spear.Game | 35 | Spear.Game |
36 | Spear.GL | 36 | Spear.GL |
37 | Spear.Math.AABB | 37 | Spear.Math.AABB |
38 | Spear.Math.Camera | 38 | Spear.Math.Camera |
39 | Spear.Math.Circle | 39 | Spear.Math.Circle |
40 | Spear.Math.Collision | 40 | Spear.Math.Collision |
41 | Spear.Math.Entity | 41 | Spear.Math.Entity |
42 | Spear.Math.Frustum | 42 | Spear.Math.Frustum |
43 | Spear.Math.Matrix3 | 43 | Spear.Math.Matrix3 |
44 | Spear.Math.Matrix4 | 44 | Spear.Math.Matrix4 |
45 | Spear.Math.MatrixUtils | 45 | Spear.Math.MatrixUtils |
46 | Spear.Math.Octree | 46 | Spear.Math.Octree |
47 | Spear.Math.Plane | 47 | Spear.Math.Plane |
48 | Spear.Math.Quaternion | 48 | Spear.Math.Quaternion |
49 | Spear.Math.Ray | 49 | Spear.Math.Ray |
50 | Spear.Math.Segment | 50 | Spear.Math.Segment |
51 | Spear.Math.Spatial2 | 51 | Spear.Math.Spatial2 |
52 | Spear.Math.Spatial3 | 52 | Spear.Math.Spatial3 |
53 | Spear.Math.Triangle | 53 | Spear.Math.Triangle |
54 | Spear.Math.Utils | 54 | Spear.Math.Utils |
55 | Spear.Math.Vector | 55 | Spear.Math.Vector |
56 | Spear.Math.Vector.Class | 56 | Spear.Math.Vector.Class |
57 | Spear.Math.Vector.Vector2 | 57 | Spear.Math.Vector.Vector2 |
58 | Spear.Math.Vector.Vector3 | 58 | Spear.Math.Vector.Vector3 |
59 | Spear.Math.Vector.Vector4 | 59 | Spear.Math.Vector.Vector4 |
60 | Spear.Render.AnimatedModel | 60 | Spear.Render.AnimatedModel |
61 | Spear.Render.Material | 61 | Spear.Render.Material |
62 | Spear.Render.Model | 62 | Spear.Render.Model |
63 | Spear.Render.Program | 63 | Spear.Render.Program |
64 | Spear.Render.StaticModel | 64 | Spear.Render.StaticModel |
65 | Spear.Scene.GameObject | 65 | Spear.Scene.GameObject |
66 | Spear.Scene.Graph | 66 | Spear.Scene.Graph |
67 | Spear.Scene.Light | 67 | Spear.Scene.Light |
68 | Spear.Scene.Loader | 68 | Spear.Scene.Loader |
69 | Spear.Scene.SceneResources | 69 | Spear.Scene.SceneResources |
70 | Spear.Sys.Store | 70 | Spear.Sys.Store |
71 | Spear.Sys.Store.ID | 71 | Spear.Sys.Store.ID |
72 | Spear.Sys.Timer | 72 | Spear.Sys.Timer |
73 | 73 | ||
74 | exposed: True | 74 | exposed: True |
75 | 75 | ||
76 | buildable: True | 76 | buildable: True |
77 | 77 | ||
78 | build-tools: hsc2hs -any | 78 | build-tools: hsc2hs -any |
79 | 79 | ||
80 | cc-options: -O2 -g -Wno-unused-result | 80 | cc-options: -O2 -g -Wno-unused-result |
81 | 81 | ||
82 | c-sources: Spear/Assets/Image/Image.c | 82 | c-sources: Spear/Assets/Image/Image.c |
83 | Spear/Assets/Image/BMP/BMP_load.c | 83 | Spear/Assets/Image/BMP/BMP_load.c |
84 | Spear/Assets/Model/Model.c | 84 | Spear/Assets/Model/Model.c |
85 | Spear/Assets/Model/MD2/MD2_load.c | 85 | Spear/Assets/Model/MD2/MD2_load.c |
86 | Spear/Assets/Model/OBJ/cvector.c | 86 | Spear/Assets/Model/OBJ/cvector.c |
87 | Spear/Assets/Model/OBJ/OBJ_load.c | 87 | Spear/Assets/Model/OBJ/OBJ_load.c |
88 | Spear/Render/RenderModel.c | 88 | Spear/Render/RenderModel.c |
89 | Spear/Sys/Timer/ctimer.c | 89 | Spear/Sys/Timer/ctimer.c |
90 | 90 | ||
91 | extensions: TypeFamilies | 91 | extensions: TypeFamilies |
92 | 92 | ||
93 | includes: Spear/Assets/Image/BMP/BMP_load.h | 93 | includes: Spear/Assets/Image/BMP/BMP_load.h |
94 | Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h | 94 | Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h |
95 | Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h | 95 | Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h |
96 | Spear/Assets/Model/OBJ/OBJ_load.h Spear/Assets/Model/OBJ/cvector.h | 96 | Spear/Assets/Model/OBJ/OBJ_load.h Spear/Assets/Model/OBJ/cvector.h |
97 | Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h | 97 | Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h |
98 | Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h | 98 | Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h |
99 | Timer/Timer.h | 99 | Timer/Timer.h |
100 | 100 | ||
101 | include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render | 101 | include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render |
102 | Spear/Sys | 102 | Spear/Sys |
103 | 103 | ||
104 | hs-source-dirs: . | 104 | hs-source-dirs: . |
105 | 105 | ||
106 | ghc-options: -O2 | 106 | ghc-options: -O2 |
107 | 107 | ||
108 | ghc-prof-options: -O2 -rtsopts -fprof-auto -fprof-cafs | 108 | ghc-prof-options: -O2 -rtsopts -fprof-auto -fprof-cafs |
diff --git a/Spear/App.hs b/Spear/App.hs index a962414..4057aa3 100644 --- a/Spear/App.hs +++ b/Spear/App.hs | |||
@@ -1,10 +1,10 @@ | |||
1 | module Spear.App | 1 | module Spear.App |
2 | ( | 2 | ( |
3 | module Spear.App.Application | 3 | module Spear.App.Application |
4 | , module Spear.App.Input | 4 | , module Spear.App.Input |
5 | ) | 5 | ) |
6 | where | 6 | where |
7 | 7 | ||
8 | 8 | ||
9 | import Spear.App.Application | 9 | import Spear.App.Application |
10 | import Spear.App.Input | 10 | import Spear.App.Input |
diff --git a/Spear/App/Application.hs b/Spear/App/Application.hs index ce52f0d..8f1e726 100644 --- a/Spear/App/Application.hs +++ b/Spear/App/Application.hs | |||
@@ -1,125 +1,143 @@ | |||
1 | module Spear.App.Application | 1 | module Spear.App.Application |
2 | ( | 2 | ( |
3 | -- * Setup | 3 | -- * Setup |
4 | Dimensions | 4 | Dimensions |
5 | , Context | 5 | , Context |
6 | , SpearWindow | 6 | , WindowTitle |
7 | , Update | 7 | , SpearWindow |
8 | , Size(..) | 8 | , Update |
9 | , DisplayBits(..) | 9 | , Size(..) |
10 | , WindowMode(..) | 10 | , DisplayBits(..) |
11 | , WindowSizeCallback | 11 | , WindowMode(..) |
12 | , setup | 12 | , WindowSizeCallback |
13 | , quit | 13 | , withWindow |
14 | -- * Main loop | 14 | -- * Main loop |
15 | , loop | 15 | , loop |
16 | , loopCapped | 16 | , loopCapped |
17 | -- * Helpers | 17 | -- * Helpers |
18 | , swapBuffers | 18 | , swapBuffers |
19 | , getParam | 19 | ) |
20 | , SpecialFeature(..) | 20 | where |
21 | , enableSpecial | 21 | |
22 | , disableSpecial | 22 | import Spear.Game |
23 | ) | 23 | import Spear.Sys.Timer as Timer |
24 | where | 24 | |
25 | 25 | import Control.Concurrent.MVar | |
26 | import Spear.Game | 26 | import Control.Monad (when) |
27 | import Spear.Sys.Timer as Timer | 27 | import Graphics.UI.GLFW as GLFW |
28 | 28 | import Graphics.Rendering.OpenGL as GL | |
29 | import Control.Applicative | 29 | |
30 | import Control.Monad (forever, when) | 30 | -- | Window dimensions. |
31 | import Control.Monad.Trans.Error | 31 | type Dimensions = (Int, Int) |
32 | import Control.Monad.Trans.Class (lift) | 32 | |
33 | import Graphics.UI.GLFW as GLFW | 33 | -- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). |
34 | import Graphics.Rendering.OpenGL as GL | 34 | type Context = (Int, Int) |
35 | import System.Exit | 35 | |
36 | import Unsafe.Coerce | 36 | type WindowTitle = String |
37 | 37 | ||
38 | -- | Window dimensions. | 38 | -- Whether the user has closed the window. |
39 | type Dimensions = (Int, Int) | 39 | type CloseRequested = MVar Bool |
40 | 40 | ||
41 | -- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). | 41 | -- | Represents a window. |
42 | type Context = (Int, Int) | 42 | data SpearWindow = SpearWindow |
43 | 43 | { closeRequest :: CloseRequested | |
44 | -- | Represents a window. | 44 | } |
45 | newtype SpearWindow = SpearWindow { rkey :: Resource } | 45 | |
46 | 46 | withWindow :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | |
47 | instance ResourceClass SpearWindow where | 47 | -> WindowSizeCallback -> (SpearWindow -> Game s a) -> Game s a |
48 | getResource = rkey | 48 | withWindow dim displayBits windowMode glVersion windowTitle onResize run = do |
49 | 49 | glfwInit | |
50 | -- | Set up an application 'SpearWindow'. | 50 | window <- setup dim displayBits windowMode glVersion windowTitle onResize |
51 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context | 51 | gs <- getGameState |
52 | -> WindowSizeCallback -> Game s SpearWindow | 52 | (a,s) <- runSubGame (run window) gs |
53 | setup (w, h) displayBits windowMode (major, minor) onResize' = do | 53 | gameIO GLFW.closeWindow |
54 | glfwInit | 54 | gameIO GLFW.terminate |
55 | gameIO $ do | 55 | saveGameState s |
56 | openWindowHint OpenGLVersionMajor major | 56 | return a |
57 | openWindowHint OpenGLVersionMinor minor | 57 | |
58 | disableSpecial AutoPollEvent | 58 | -- Set up an application 'SpearWindow'. |
59 | 59 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | |
60 | let dimensions = GL.Size (unsafeCoerce w) (unsafeCoerce h) | 60 | -> WindowSizeCallback -> Game s SpearWindow |
61 | result <- openWindow dimensions displayBits windowMode | 61 | setup (w, h) displayBits windowMode (major, minor) wndTitle onResize' = do |
62 | windowTitle $= "Spear Game Framework" | 62 | closeRequest <- gameIO $ newEmptyMVar |
63 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) | 63 | gameIO $ do |
64 | 64 | openWindowHint OpenGLVersionMajor major | |
65 | windowSizeCallback $= (onResize onResize') | 65 | openWindowHint OpenGLVersionMinor minor |
66 | onResize' (Size (fromIntegral w) (fromIntegral h)) | 66 | openWindowHint OpenGLProfile OpenGLCompatProfile |
67 | 67 | disableSpecial AutoPollEvent | |
68 | initialiseTimingSubsystem | 68 | |
69 | 69 | let dimensions = GL.Size (fromIntegral w) (fromIntegral h) | |
70 | rkey <- register quit | 70 | result <- openWindow dimensions displayBits windowMode |
71 | return $ SpearWindow rkey | 71 | windowTitle $= case wndTitle of |
72 | 72 | Nothing -> "Spear Game Framework" | |
73 | glfwInit :: Game s () | 73 | Just title -> title |
74 | glfwInit = do | 74 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) |
75 | result <- gameIO GLFW.initialize | 75 | |
76 | case result of | 76 | windowSizeCallback $= (onResize onResize') |
77 | False -> gameError "GLFW.initialize failed" | 77 | windowCloseCallback $= (onWindowClose closeRequest) |
78 | True -> return () | 78 | onResize' (Size (fromIntegral w) (fromIntegral h)) |
79 | 79 | ||
80 | -- | Close the application's window. | 80 | return $ SpearWindow closeRequest |
81 | quit :: IO () | 81 | |
82 | quit = GLFW.terminate | 82 | glfwInit :: Game s () |
83 | 83 | glfwInit = do | |
84 | -- | Return true if the application should continue running, false otherwise. | 84 | result <- gameIO GLFW.initialize |
85 | type Update s = Float -> Game s (Bool) | 85 | case result of |
86 | 86 | False -> gameError "GLFW.initialize failed" | |
87 | -- | Run the application's main loop. | 87 | True -> return () |
88 | loop :: Update s -> Game s () | 88 | |
89 | loop update = do | 89 | -- | Return true if the application should continue running, false otherwise. |
90 | timer <- gameIO $ start newTimer | 90 | type Update s = Float -> Game s (Bool) |
91 | run timer update | 91 | |
92 | 92 | -- | Run the application's main loop. | |
93 | run :: Timer -> Update s -> Game s () | 93 | loop :: SpearWindow -> Update s -> Game s () |
94 | run timer update = do | 94 | loop wnd update = do |
95 | timer' <- gameIO $ tick timer | 95 | gs <- getGameState |
96 | continue <- update $ getDelta timer' | 96 | flip runSubGame gs $ do |
97 | opened <- gameIO $ getParam Opened | 97 | timer <- gameIO $ start newTimer |
98 | case continue && opened of | 98 | run (closeRequest wnd) timer update |
99 | False -> return () | 99 | return () |
100 | True -> run timer' update | 100 | |
101 | 101 | run :: CloseRequested -> Timer -> Update s -> Game s () | |
102 | -- | Run the application's main loop, with a limit on the frame rate. | 102 | run closeRequest timer update = do |
103 | loopCapped :: Int -> Update s -> Game s () | 103 | timer' <- gameIO $ tick timer |
104 | loopCapped maxFPS update = do | 104 | continue <- update $ getDelta timer' |
105 | let ddt = 1.0 / (fromIntegral maxFPS) | 105 | close <- gameIO $ getRequest closeRequest |
106 | timer <- gameIO $ start newTimer | 106 | when (continue && (not close)) $ run closeRequest timer' update |
107 | runCapped ddt timer update | 107 | |
108 | 108 | -- | Run the application's main loop with a limit on the frame rate. | |
109 | runCapped :: Float -> Timer -> Update s -> Game s () | 109 | loopCapped :: SpearWindow -> Int -> Update s -> Game s () |
110 | runCapped ddt timer update = do | 110 | loopCapped wnd maxFPS update = do |
111 | timer' <- gameIO $ tick timer | 111 | gs <- getGameState |
112 | continue <- update $ getDelta timer' | 112 | flip runSubGame gs $ do |
113 | opened <- gameIO $ getParam Opened | 113 | let ddt = 1.0 / (fromIntegral maxFPS) |
114 | case continue && opened of | 114 | closeReq = closeRequest wnd |
115 | False -> return () | 115 | frameTimer <- gameIO $ start newTimer |
116 | True -> do | 116 | controlTimer <- gameIO $ start newTimer |
117 | t'' <- gameIO $ tick timer' | 117 | runCapped closeReq ddt frameTimer controlTimer update |
118 | let dt = getDelta t'' | 118 | return () |
119 | when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) | 119 | |
120 | runCapped ddt timer' update | 120 | runCapped :: CloseRequested -> Float -> Timer -> Timer -> Update s -> Game s () |
121 | 121 | runCapped closeRequest ddt frameTimer controlTimer update = do | |
122 | onResize :: WindowSizeCallback -> Size -> IO () | 122 | controlTimer' <- gameIO $ tick controlTimer |
123 | onResize callback s@(Size w h) = do | 123 | frameTimer' <- gameIO $ tick frameTimer |
124 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) | 124 | continue <- update $ getDelta frameTimer' |
125 | callback s | 125 | close <- gameIO $ getRequest closeRequest |
126 | controlTimer'' <- gameIO $ tick controlTimer' | ||
127 | let dt = getDelta controlTimer'' | ||
128 | when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) | ||
129 | when (continue && (not close)) $ | ||
130 | runCapped closeRequest ddt frameTimer' controlTimer'' update | ||
131 | |||
132 | getRequest :: MVar Bool -> IO Bool | ||
133 | getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of | ||
134 | Nothing -> False | ||
135 | Just x -> x | ||
136 | |||
137 | onResize :: WindowSizeCallback -> Size -> IO () | ||
138 | onResize callback s@(Size w h) = do | ||
139 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) | ||
140 | callback s | ||
141 | |||
142 | onWindowClose :: MVar Bool -> WindowCloseCallback | ||
143 | onWindowClose closeRequest = putMVar closeRequest True >> return False | ||
diff --git a/Spear/App/Input.hs b/Spear/App/Input.hs index d49a3f7..3a4fc99 100644 --- a/Spear/App/Input.hs +++ b/Spear/App/Input.hs | |||
@@ -1,265 +1,265 @@ | |||
1 | module Spear.App.Input | 1 | module Spear.App.Input |
2 | ( | 2 | ( |
3 | -- * Data types | 3 | -- * Data types |
4 | Key(..) | 4 | Key(..) |
5 | , MouseButton(..) | 5 | , MouseButton(..) |
6 | , MouseProp(..) | 6 | , MouseProp(..) |
7 | , Keyboard | 7 | , Keyboard |
8 | , Mouse(..) | 8 | , Mouse(..) |
9 | , Input(..) | 9 | , Input(..) |
10 | , ButtonDelay | 10 | , ButtonDelay |
11 | , DelayedMouse | 11 | , DelayedMouse |
12 | -- * Input state querying | 12 | -- * Input state querying |
13 | , newKeyboard | 13 | , newKeyboard |
14 | , getKeyboard | 14 | , getKeyboard |
15 | , newMouse | 15 | , newMouse |
16 | , getMouse | 16 | , getMouse |
17 | , newInput | 17 | , newInput |
18 | , getInput | 18 | , getInput |
19 | , pollInput | 19 | , pollInput |
20 | -- * Toggled input | 20 | -- * Toggled input |
21 | , toggledMouse | 21 | , toggledMouse |
22 | , toggledKeyboard | 22 | , toggledKeyboard |
23 | -- * Delayed input | 23 | -- * Delayed input |
24 | , newDM | 24 | , newDM |
25 | , updateDM | 25 | , updateDM |
26 | , delayedMouse | 26 | , delayedMouse |
27 | -- * Input modifiers | 27 | -- * Input modifiers |
28 | , setMousePosition | 28 | , setMousePosition |
29 | , setMouseWheel | 29 | , setMouseWheel |
30 | ) | 30 | ) |
31 | where | 31 | where |
32 | 32 | ||
33 | import Data.Char (ord) | 33 | import Data.Char (ord) |
34 | import qualified Data.Vector.Unboxed as V | 34 | import qualified Data.Vector.Unboxed as V |
35 | import qualified Graphics.UI.GLFW as GLFW | 35 | import qualified Graphics.UI.GLFW as GLFW |
36 | import Graphics.Rendering.OpenGL.GL.CoordTrans | 36 | import Graphics.Rendering.OpenGL.GL.CoordTrans |
37 | import Graphics.Rendering.OpenGL.GL.StateVar | 37 | import Graphics.Rendering.OpenGL.GL.StateVar |
38 | 38 | ||
39 | data Key | 39 | data Key |
40 | = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H | 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 | 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 | 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 | 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 | 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 | 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 | 46 | | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN |
47 | | KEY_LEFT | KEY_RIGHT | 47 | | KEY_LEFT | KEY_RIGHT |
48 | deriving (Enum, Bounded) | 48 | deriving (Enum, Bounded) |
49 | 49 | ||
50 | type Keyboard = Key -> Bool | 50 | type Keyboard = Key -> Bool |
51 | 51 | ||
52 | data MouseButton = LMB | RMB | MMB | 52 | data MouseButton = LMB | RMB | MMB |
53 | deriving (Enum, Bounded) | 53 | deriving (Enum, Bounded) |
54 | 54 | ||
55 | data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta | 55 | data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta |
56 | deriving Enum | 56 | deriving Enum |
57 | 57 | ||
58 | data Mouse = Mouse | 58 | data Mouse = Mouse |
59 | { button :: MouseButton -> Bool | 59 | { button :: MouseButton -> Bool |
60 | , property :: MouseProp -> Float | 60 | , property :: MouseProp -> Float |
61 | } | 61 | } |
62 | 62 | ||
63 | data Input = Input | 63 | data Input = Input |
64 | { keyboard :: Keyboard | 64 | { keyboard :: Keyboard |
65 | , mouse :: Mouse | 65 | , mouse :: Mouse |
66 | } | 66 | } |
67 | 67 | ||
68 | -- | Return a new dummy keyboard. | 68 | -- | Return a new dummy keyboard. |
69 | -- | 69 | -- |
70 | -- This function should be called to get an initial keyboard. | 70 | -- This function should be called to get an initial keyboard. |
71 | -- | 71 | -- |
72 | -- The returned keyboard has all of its keys unpressed. | 72 | -- The returned keyboard has all of its keys unpressed. |
73 | -- | 73 | -- |
74 | -- For further keyboard updates, see 'getKeyboard'. | 74 | -- For further keyboard updates, see 'getKeyboard'. |
75 | newKeyboard :: Keyboard | 75 | newKeyboard :: Keyboard |
76 | newKeyboard = const False | 76 | newKeyboard = const False |
77 | 77 | ||
78 | -- | Get the keyboard. | 78 | -- | Get the keyboard. |
79 | getKeyboard :: IO Keyboard | 79 | getKeyboard :: IO Keyboard |
80 | getKeyboard = | 80 | getKeyboard = |
81 | let keyboard' :: V.Vector Bool -> Keyboard | 81 | let keyboard' :: V.Vector Bool -> Keyboard |
82 | keyboard' keystate key = keystate V.! fromEnum key | 82 | keyboard' keystate key = keystate V.! fromEnum key |
83 | keys = fmap toEnum [0..fromEnum (maxBound :: Key)] | 83 | keys = fmap toEnum [0..fromEnum (maxBound :: Key)] |
84 | in | 84 | in |
85 | (fmap (V.fromList . fmap ((==) GLFW.Press)) . mapM GLFW.getKey . fmap toGLFWkey $ keys) | 85 | (fmap (V.fromList . fmap ((==) GLFW.Press)) . mapM GLFW.getKey . fmap toGLFWkey $ keys) |
86 | >>= return . keyboard' | 86 | >>= return . keyboard' |
87 | 87 | ||
88 | -- | Return a new dummy mouse. | 88 | -- | Return a new dummy mouse. |
89 | -- | 89 | -- |
90 | -- This function should be called to get an initial mouse. | 90 | -- This function should be called to get an initial mouse. |
91 | -- | 91 | -- |
92 | -- The returned mouse has all keys unpressed, position set to (0,0) and 0 deta values. | 92 | -- The returned mouse has all keys unpressed, position set to (0,0) and 0 deta values. |
93 | -- | 93 | -- |
94 | -- For further mouse updates, see 'getMouse'. | 94 | -- For further mouse updates, see 'getMouse'. |
95 | newMouse :: Mouse | 95 | newMouse :: Mouse |
96 | newMouse = Mouse (const False) (const 0) | 96 | newMouse = Mouse (const False) (const 0) |
97 | 97 | ||
98 | -- | Get the mouse. | 98 | -- | Get the mouse. |
99 | -- | 99 | -- |
100 | -- The previous mouse state is required to compute position deltas. | 100 | -- The previous mouse state is required to compute position deltas. |
101 | getMouse :: Mouse -> IO Mouse | 101 | getMouse :: Mouse -> IO Mouse |
102 | getMouse oldMouse = | 102 | getMouse oldMouse = |
103 | let getButton :: V.Vector Bool -> MouseButton -> Bool | 103 | let getButton :: V.Vector Bool -> MouseButton -> Bool |
104 | getButton mousestate button = mousestate V.! fromEnum button | 104 | getButton mousestate button = mousestate V.! fromEnum button |
105 | 105 | ||
106 | getProp :: V.Vector Float -> MouseProp -> Float | 106 | getProp :: V.Vector Float -> MouseProp -> Float |
107 | getProp props prop = props V.! fromEnum prop | 107 | getProp props prop = props V.! fromEnum prop |
108 | 108 | ||
109 | props xpos ypos wheel = V.fromList | 109 | props xpos ypos wheel = V.fromList |
110 | [ xpos | 110 | [ xpos |
111 | , ypos | 111 | , ypos |
112 | , xpos - property oldMouse MouseX | 112 | , xpos - property oldMouse MouseX |
113 | , ypos - property oldMouse MouseY | 113 | , ypos - property oldMouse MouseY |
114 | , wheel | 114 | , wheel |
115 | , wheel - property oldMouse Wheel | 115 | , wheel - property oldMouse Wheel |
116 | ] | 116 | ] |
117 | 117 | ||
118 | getButtonState = | 118 | getButtonState = |
119 | fmap (V.fromList . fmap ((==) GLFW.Press)) . | 119 | fmap (V.fromList . fmap ((==) GLFW.Press)) . |
120 | mapM GLFW.getMouseButton . | 120 | mapM GLFW.getMouseButton . |
121 | fmap toGLFWbutton $ buttons | 121 | fmap toGLFWbutton $ buttons |
122 | 122 | ||
123 | buttons = fmap toEnum [0..fromEnum (maxBound :: MouseButton)] | 123 | buttons = fmap toEnum [0..fromEnum (maxBound :: MouseButton)] |
124 | in do | 124 | in do |
125 | Position xpos ypos <- get GLFW.mousePos | 125 | Position xpos ypos <- get GLFW.mousePos |
126 | wheel <- get GLFW.mouseWheel | 126 | wheel <- get GLFW.mouseWheel |
127 | buttonState <- getButtonState | 127 | buttonState <- getButtonState |
128 | return $ Mouse | 128 | return $ Mouse |
129 | { button = getButton buttonState | 129 | { button = getButton buttonState |
130 | , property = getProp $ props (fromIntegral xpos) (fromIntegral ypos) (fromIntegral wheel) | 130 | , property = getProp $ props (fromIntegral xpos) (fromIntegral ypos) (fromIntegral wheel) |
131 | } | 131 | } |
132 | 132 | ||
133 | -- | Return a new dummy input. | 133 | -- | Return a new dummy input. |
134 | newInput :: Input | 134 | newInput :: Input |
135 | newInput = Input newKeyboard newMouse | 135 | newInput = Input newKeyboard newMouse |
136 | 136 | ||
137 | -- | Get input devices. | 137 | -- | Get input devices. |
138 | getInput :: Input -> IO Input | 138 | getInput :: Input -> IO Input |
139 | getInput (Input _ oldMouse) = do | 139 | getInput (Input _ oldMouse) = do |
140 | keyboard <- getKeyboard | 140 | keyboard <- getKeyboard |
141 | mouse <- getMouse oldMouse | 141 | mouse <- getMouse oldMouse |
142 | return $ Input keyboard mouse | 142 | return $ Input keyboard mouse |
143 | 143 | ||
144 | -- | Poll input devices. | 144 | -- | Poll input devices. |
145 | pollInput :: IO () | 145 | pollInput :: IO () |
146 | pollInput = GLFW.pollEvents | 146 | pollInput = GLFW.pollEvents |
147 | 147 | ||
148 | -- | Return a mouse that reacts to button toggles. | 148 | -- | Return a mouse that reacts to button toggles. |
149 | toggledMouse :: Mouse -- ^ Previous mouse state. | 149 | toggledMouse :: Mouse -- ^ Previous mouse state. |
150 | -> Mouse -- ^ Current mouse state. | 150 | -> Mouse -- ^ Current mouse state. |
151 | -> Mouse -- ^ Toggled mouse. | 151 | -> Mouse -- ^ Toggled mouse. |
152 | 152 | ||
153 | toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) } | 153 | toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) } |
154 | 154 | ||
155 | -- | Return a keyboard that reacts to key toggles. | 155 | -- | Return a keyboard that reacts to key toggles. |
156 | toggledKeyboard :: Keyboard -- ^ Previous keyboard state. | 156 | toggledKeyboard :: Keyboard -- ^ Previous keyboard state. |
157 | -> Keyboard -- ^ Current keyboard state. | 157 | -> Keyboard -- ^ Current keyboard state. |
158 | -> Keyboard -- ^ Toggled keyboard. | 158 | -> Keyboard -- ^ Toggled keyboard. |
159 | 159 | ||
160 | toggledKeyboard prev cur key = cur key && not (prev key) | 160 | toggledKeyboard prev cur key = cur key && not (prev key) |
161 | 161 | ||
162 | -- | Delay configuration for each mouse button. | 162 | -- | Delay configuration for each mouse button. |
163 | type ButtonDelay = MouseButton -> Float | 163 | type ButtonDelay = MouseButton -> Float |
164 | 164 | ||
165 | 165 | ||
166 | -- | Accumulated delays for each mouse button. | 166 | -- | Accumulated delays for each mouse button. |
167 | data DelayedMouse = DelayedMouse | 167 | data DelayedMouse = DelayedMouse |
168 | { delayedMouse :: Mouse | 168 | { delayedMouse :: Mouse |
169 | , delay :: ButtonDelay | 169 | , delay :: ButtonDelay |
170 | , accum :: V.Vector Float | 170 | , accum :: V.Vector Float |
171 | } | 171 | } |
172 | 172 | ||
173 | newDM :: ButtonDelay -- ^ Delay configuration for each button. | 173 | newDM :: ButtonDelay -- ^ Delay configuration for each button. |
174 | -> DelayedMouse | 174 | -> DelayedMouse |
175 | newDM delay = DelayedMouse newMouse delay $ | 175 | newDM delay = DelayedMouse newMouse delay $ |
176 | V.replicate (fromEnum (maxBound :: MouseButton)) 0 | 176 | V.replicate (fromEnum (maxBound :: MouseButton)) 0 |
177 | 177 | ||
178 | updateDM :: DelayedMouse -- ^ Current mouse state. | 178 | updateDM :: DelayedMouse -- ^ Current mouse state. |
179 | -> Float -- ^ Time elapsed since last udpate. | 179 | -> Float -- ^ Time elapsed since last udpate. |
180 | -> DelayedMouse | 180 | -> DelayedMouse |
181 | 181 | ||
182 | updateDM (DelayedMouse mouse delay accum) dt = | 182 | updateDM (DelayedMouse mouse delay accum) dt = |
183 | let | 183 | let |
184 | time b = dt + accum' V.! fromEnum b | 184 | time b = dt + accum' V.! fromEnum b |
185 | active b = time b >= delay b | 185 | active b = time b >= delay b |
186 | button' b = active b && button mouse b | 186 | button' b = active b && button mouse b |
187 | accum' = accum V.// fmap newDelay [0 .. fromEnum (maxBound :: MouseButton)] | 187 | accum' = accum V.// fmap newDelay [0 .. fromEnum (maxBound :: MouseButton)] |
188 | newDelay x = let b = toEnum x | 188 | newDelay x = let b = toEnum x |
189 | in (x, if button' b then 0 else time b) | 189 | in (x, if button' b then 0 else time b) |
190 | in | 190 | in |
191 | DelayedMouse mouse { button = button' } delay accum' | 191 | DelayedMouse mouse { button = button' } delay accum' |
192 | 192 | ||
193 | -- | Set the mouse position. | 193 | -- | Set the mouse position. |
194 | setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse | 194 | setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse |
195 | setMousePosition (x,y) mouse = do | 195 | setMousePosition (x,y) mouse = do |
196 | GLFW.mousePos $= Position (fromIntegral x) (fromIntegral y) | 196 | GLFW.mousePos $= Position (fromIntegral x) (fromIntegral y) |
197 | getMouse mouse | 197 | getMouse mouse |
198 | 198 | ||
199 | -- | Set the mouse wheel. | 199 | -- | Set the mouse wheel. |
200 | setMouseWheel :: Integral a => a -> Mouse -> IO Mouse | 200 | setMouseWheel :: Integral a => a -> Mouse -> IO Mouse |
201 | setMouseWheel w mouse = do | 201 | setMouseWheel w mouse = do |
202 | GLFW.mouseWheel $= (fromIntegral w) | 202 | GLFW.mouseWheel $= (fromIntegral w) |
203 | getMouse mouse | 203 | getMouse mouse |
204 | 204 | ||
205 | toGLFWkey :: Key -> Int | 205 | toGLFWkey :: Key -> Int |
206 | toGLFWkey KEY_A = ord 'A' | 206 | toGLFWkey KEY_A = ord 'A' |
207 | toGLFWkey KEY_B = ord 'B' | 207 | toGLFWkey KEY_B = ord 'B' |
208 | toGLFWkey KEY_C = ord 'C' | 208 | toGLFWkey KEY_C = ord 'C' |
209 | toGLFWkey KEY_D = ord 'D' | 209 | toGLFWkey KEY_D = ord 'D' |
210 | toGLFWkey KEY_E = ord 'E' | 210 | toGLFWkey KEY_E = ord 'E' |
211 | toGLFWkey KEY_F = ord 'F' | 211 | toGLFWkey KEY_F = ord 'F' |
212 | toGLFWkey KEY_G = ord 'G' | 212 | toGLFWkey KEY_G = ord 'G' |
213 | toGLFWkey KEY_H = ord 'H' | 213 | toGLFWkey KEY_H = ord 'H' |
214 | toGLFWkey KEY_I = ord 'I' | 214 | toGLFWkey KEY_I = ord 'I' |
215 | toGLFWkey KEY_J = ord 'J' | 215 | toGLFWkey KEY_J = ord 'J' |
216 | toGLFWkey KEY_K = ord 'K' | 216 | toGLFWkey KEY_K = ord 'K' |
217 | toGLFWkey KEY_L = ord 'L' | 217 | toGLFWkey KEY_L = ord 'L' |
218 | toGLFWkey KEY_M = ord 'M' | 218 | toGLFWkey KEY_M = ord 'M' |
219 | toGLFWkey KEY_N = ord 'N' | 219 | toGLFWkey KEY_N = ord 'N' |
220 | toGLFWkey KEY_O = ord 'O' | 220 | toGLFWkey KEY_O = ord 'O' |
221 | toGLFWkey KEY_P = ord 'P' | 221 | toGLFWkey KEY_P = ord 'P' |
222 | toGLFWkey KEY_Q = ord 'Q' | 222 | toGLFWkey KEY_Q = ord 'Q' |
223 | toGLFWkey KEY_R = ord 'R' | 223 | toGLFWkey KEY_R = ord 'R' |
224 | toGLFWkey KEY_S = ord 'S' | 224 | toGLFWkey KEY_S = ord 'S' |
225 | toGLFWkey KEY_T = ord 'T' | 225 | toGLFWkey KEY_T = ord 'T' |
226 | toGLFWkey KEY_U = ord 'U' | 226 | toGLFWkey KEY_U = ord 'U' |
227 | toGLFWkey KEY_V = ord 'V' | 227 | toGLFWkey KEY_V = ord 'V' |
228 | toGLFWkey KEY_W = ord 'W' | 228 | toGLFWkey KEY_W = ord 'W' |
229 | toGLFWkey KEY_X = ord 'X' | 229 | toGLFWkey KEY_X = ord 'X' |
230 | toGLFWkey KEY_Y = ord 'Y' | 230 | toGLFWkey KEY_Y = ord 'Y' |
231 | toGLFWkey KEY_Z = ord 'Z' | 231 | toGLFWkey KEY_Z = ord 'Z' |
232 | toGLFWkey KEY_0 = ord '0' | 232 | toGLFWkey KEY_0 = ord '0' |
233 | toGLFWkey KEY_1 = ord '1' | 233 | toGLFWkey KEY_1 = ord '1' |
234 | toGLFWkey KEY_2 = ord '2' | 234 | toGLFWkey KEY_2 = ord '2' |
235 | toGLFWkey KEY_3 = ord '3' | 235 | toGLFWkey KEY_3 = ord '3' |
236 | toGLFWkey KEY_4 = ord '4' | 236 | toGLFWkey KEY_4 = ord '4' |
237 | toGLFWkey KEY_5 = ord '5' | 237 | toGLFWkey KEY_5 = ord '5' |
238 | toGLFWkey KEY_6 = ord '6' | 238 | toGLFWkey KEY_6 = ord '6' |
239 | toGLFWkey KEY_7 = ord '7' | 239 | toGLFWkey KEY_7 = ord '7' |
240 | toGLFWkey KEY_8 = ord '8' | 240 | toGLFWkey KEY_8 = ord '8' |
241 | toGLFWkey KEY_9 = ord '9' | 241 | toGLFWkey KEY_9 = ord '9' |
242 | toGLFWkey KEY_F1 = fromEnum GLFW.F1 | 242 | toGLFWkey KEY_F1 = fromEnum GLFW.F1 |
243 | toGLFWkey KEY_F2 = fromEnum GLFW.F2 | 243 | toGLFWkey KEY_F2 = fromEnum GLFW.F2 |
244 | toGLFWkey KEY_F3 = fromEnum GLFW.F3 | 244 | toGLFWkey KEY_F3 = fromEnum GLFW.F3 |
245 | toGLFWkey KEY_F4 = fromEnum GLFW.F4 | 245 | toGLFWkey KEY_F4 = fromEnum GLFW.F4 |
246 | toGLFWkey KEY_F5 = fromEnum GLFW.F5 | 246 | toGLFWkey KEY_F5 = fromEnum GLFW.F5 |
247 | toGLFWkey KEY_F6 = fromEnum GLFW.F6 | 247 | toGLFWkey KEY_F6 = fromEnum GLFW.F6 |
248 | toGLFWkey KEY_F7 = fromEnum GLFW.F7 | 248 | toGLFWkey KEY_F7 = fromEnum GLFW.F7 |
249 | toGLFWkey KEY_F8 = fromEnum GLFW.F8 | 249 | toGLFWkey KEY_F8 = fromEnum GLFW.F8 |
250 | toGLFWkey KEY_F9 = fromEnum GLFW.F9 | 250 | toGLFWkey KEY_F9 = fromEnum GLFW.F9 |
251 | toGLFWkey KEY_F10 = fromEnum GLFW.F10 | 251 | toGLFWkey KEY_F10 = fromEnum GLFW.F10 |
252 | toGLFWkey KEY_F11 = fromEnum GLFW.F11 | 252 | toGLFWkey KEY_F11 = fromEnum GLFW.F11 |
253 | toGLFWkey KEY_F12 = fromEnum GLFW.F12 | 253 | toGLFWkey KEY_F12 = fromEnum GLFW.F12 |
254 | toGLFWkey KEY_ESC = fromEnum GLFW.ESC | 254 | toGLFWkey KEY_ESC = fromEnum GLFW.ESC |
255 | toGLFWkey KEY_SPACE = ord ' ' | 255 | toGLFWkey KEY_SPACE = ord ' ' |
256 | toGLFWkey KEY_UP = fromEnum GLFW.UP | 256 | toGLFWkey KEY_UP = fromEnum GLFW.UP |
257 | toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN | 257 | toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN |
258 | toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT | 258 | toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT |
259 | toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT | 259 | toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT |
260 | 260 | ||
261 | 261 | ||
262 | toGLFWbutton :: MouseButton -> GLFW.MouseButton | 262 | toGLFWbutton :: MouseButton -> GLFW.MouseButton |
263 | toGLFWbutton LMB = GLFW.ButtonLeft | 263 | toGLFWbutton LMB = GLFW.ButtonLeft |
264 | toGLFWbutton RMB = GLFW.ButtonRight | 264 | toGLFWbutton RMB = GLFW.ButtonRight |
265 | toGLFWbutton MMB = GLFW.ButtonMiddle | 265 | toGLFWbutton MMB = GLFW.ButtonMiddle |
diff --git a/Spear/Assets/Image.hsc b/Spear/Assets/Image.hsc index 0efbca6..f9fc025 100644 --- a/Spear/Assets/Image.hsc +++ b/Spear/Assets/Image.hsc | |||
@@ -1,126 +1,126 @@ | |||
1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} | 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} |
2 | 2 | ||
3 | module Spear.Assets.Image | 3 | module Spear.Assets.Image |
4 | ( | 4 | ( |
5 | -- * Data types | 5 | -- * Data types |
6 | Image | 6 | Image |
7 | -- * Loading and unloading | 7 | -- * Loading and unloading |
8 | , loadImage | 8 | , loadImage |
9 | -- * Accessors | 9 | -- * Accessors |
10 | , width | 10 | , width |
11 | , height | 11 | , height |
12 | , bpp | 12 | , bpp |
13 | , pixels | 13 | , pixels |
14 | ) | 14 | ) |
15 | where | 15 | where |
16 | 16 | ||
17 | import Spear.Game | 17 | import Spear.Game |
18 | import Foreign.Ptr | 18 | import Foreign.Ptr |
19 | import Foreign.Storable | 19 | import Foreign.Storable |
20 | import Foreign.C.Types | 20 | import Foreign.C.Types |
21 | import Foreign.C.String | 21 | import Foreign.C.String |
22 | import Foreign.Marshal.Utils as Foreign (with) | 22 | import Foreign.Marshal.Utils as Foreign (with) |
23 | import Foreign.Marshal.Alloc (alloca) | 23 | import Foreign.Marshal.Alloc (alloca) |
24 | import Data.List (splitAt, elemIndex) | 24 | import Data.List (splitAt, elemIndex) |
25 | import Data.Char (toLower) | 25 | import Data.Char (toLower) |
26 | 26 | ||
27 | #include "Image.h" | 27 | #include "Image.h" |
28 | #include "BMP/BMP_load.h" | 28 | #include "BMP/BMP_load.h" |
29 | 29 | ||
30 | data ImageErrorCode | 30 | data ImageErrorCode |
31 | = ImageSuccess | 31 | = ImageSuccess |
32 | | ImageReadError | 32 | | ImageReadError |
33 | | ImageMemoryAllocationError | 33 | | ImageMemoryAllocationError |
34 | | ImageFileNotFound | 34 | | ImageFileNotFound |
35 | | ImageInvalidFormat | 35 | | ImageInvalidFormat |
36 | | ImageNoSuitableLoader | 36 | | ImageNoSuitableLoader |
37 | deriving (Eq, Enum, Show) | 37 | deriving (Eq, Enum, Show) |
38 | 38 | ||
39 | data CImage = CImage | 39 | data CImage = CImage |
40 | { cwidth :: CInt | 40 | { cwidth :: CInt |
41 | , cheight :: CInt | 41 | , cheight :: CInt |
42 | , cbpp :: CInt | 42 | , cbpp :: CInt |
43 | , cpixels :: Ptr CUChar | 43 | , cpixels :: Ptr CUChar |
44 | } | 44 | } |
45 | 45 | ||
46 | instance Storable CImage where | 46 | instance Storable CImage where |
47 | sizeOf _ = #{size Image} | 47 | sizeOf _ = #{size Image} |
48 | alignment _ = alignment (undefined :: CInt) | 48 | alignment _ = alignment (undefined :: CInt) |
49 | 49 | ||
50 | peek ptr = do | 50 | peek ptr = do |
51 | width <- #{peek Image, width} ptr | 51 | width <- #{peek Image, width} ptr |
52 | height <- #{peek Image, height} ptr | 52 | height <- #{peek Image, height} ptr |
53 | bpp <- #{peek Image, bpp} ptr | 53 | bpp <- #{peek Image, bpp} ptr |
54 | pixels <- #{peek Image, pixels} ptr | 54 | pixels <- #{peek Image, pixels} ptr |
55 | return $ CImage width height bpp pixels | 55 | return $ CImage width height bpp pixels |
56 | 56 | ||
57 | poke ptr (CImage width height bpp pixels) = do | 57 | poke ptr (CImage width height bpp pixels) = do |
58 | #{poke Image, width} ptr width | 58 | #{poke Image, width} ptr width |
59 | #{poke Image, height} ptr height | 59 | #{poke Image, height} ptr height |
60 | #{poke Image, bpp} ptr bpp | 60 | #{poke Image, bpp} ptr bpp |
61 | #{poke Image, pixels} ptr pixels | 61 | #{poke Image, pixels} ptr pixels |
62 | 62 | ||
63 | -- | Represents an image 'Resource'. | 63 | -- | Represents an image 'Resource'. |
64 | data Image = Image | 64 | data Image = Image |
65 | { imageData :: CImage | 65 | { imageData :: CImage |
66 | , rkey :: Resource | 66 | , rkey :: Resource |
67 | } | 67 | } |
68 | 68 | ||
69 | instance ResourceClass Image where | 69 | instance ResourceClass Image where |
70 | getResource = rkey | 70 | getResource = rkey |
71 | 71 | ||
72 | foreign import ccall "Image.h image_free" | 72 | foreign import ccall "Image.h image_free" |
73 | image_free :: Ptr CImage -> IO () | 73 | image_free :: Ptr CImage -> IO () |
74 | 74 | ||
75 | foreign import ccall "BMP_load.h BMP_load" | 75 | foreign import ccall "BMP_load.h BMP_load" |
76 | bmp_load' :: Ptr CChar -> Ptr CImage -> IO Int | 76 | bmp_load' :: Ptr CChar -> Ptr CImage -> IO Int |
77 | 77 | ||
78 | bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode | 78 | bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode |
79 | bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code | 79 | bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code |
80 | 80 | ||
81 | -- | Load the image specified by the given file. | 81 | -- | Load the image specified by the given file. |
82 | loadImage :: FilePath -> Game s Image | 82 | loadImage :: FilePath -> Game s Image |
83 | loadImage file = do | 83 | loadImage file = do |
84 | dotPos <- case elemIndex '.' file of | 84 | dotPos <- case elemIndex '.' file of |
85 | Nothing -> gameError $ "file name has no extension: " ++ file | 85 | Nothing -> gameError $ "file name has no extension: " ++ file |
86 | Just p -> return p | 86 | Just p -> return p |
87 | 87 | ||
88 | let ext = map toLower . tail . snd $ splitAt dotPos file | 88 | let ext = map toLower . tail . snd $ splitAt dotPos file |
89 | 89 | ||
90 | result <- gameIO . alloca $ \ptr -> do | 90 | result <- gameIO . alloca $ \ptr -> do |
91 | status <- withCString file $ \fileCstr -> do | 91 | status <- withCString file $ \fileCstr -> do |
92 | case ext of | 92 | case ext of |
93 | "bmp" -> bmp_load fileCstr ptr | 93 | "bmp" -> bmp_load fileCstr ptr |
94 | _ -> return ImageNoSuitableLoader | 94 | _ -> return ImageNoSuitableLoader |
95 | 95 | ||
96 | case status of | 96 | case status of |
97 | ImageSuccess -> peek ptr >>= return . Right | 97 | ImageSuccess -> peek ptr >>= return . Right |
98 | ImageReadError -> return . Left $ "read error" | 98 | ImageReadError -> return . Left $ "read error" |
99 | ImageMemoryAllocationError -> return . Left $ "memory allocation error" | 99 | ImageMemoryAllocationError -> return . Left $ "memory allocation error" |
100 | ImageFileNotFound -> return . Left $ "file not found" | 100 | ImageFileNotFound -> return . Left $ "file not found" |
101 | ImageInvalidFormat -> return . Left $ "invalid format" | 101 | ImageInvalidFormat -> return . Left $ "invalid format" |
102 | ImageNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext | 102 | ImageNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext |
103 | 103 | ||
104 | case result of | 104 | case result of |
105 | Right image -> register (freeImage image) >>= return . Image image | 105 | Right image -> register (freeImage image) >>= return . Image image |
106 | Left err -> gameError $ "loadImage: " ++ err | 106 | Left err -> gameError $ "loadImage: " ++ err |
107 | 107 | ||
108 | -- | Free the given 'CImage'. | 108 | -- | Free the given 'CImage'. |
109 | freeImage :: CImage -> IO () | 109 | freeImage :: CImage -> IO () |
110 | freeImage image = Foreign.with image image_free | 110 | freeImage image = Foreign.with image image_free |
111 | 111 | ||
112 | -- | Return the given image's width. | 112 | -- | Return the given image's width. |
113 | width :: Image -> Int | 113 | width :: Image -> Int |
114 | width = fromIntegral . cwidth . imageData | 114 | width = fromIntegral . cwidth . imageData |
115 | 115 | ||
116 | -- | Return the given image's height. | 116 | -- | Return the given image's height. |
117 | height :: Image -> Int | 117 | height :: Image -> Int |
118 | height = fromIntegral . cheight . imageData | 118 | height = fromIntegral . cheight . imageData |
119 | 119 | ||
120 | -- | Return the given image's bits per pixel. | 120 | -- | Return the given image's bits per pixel. |
121 | bpp :: Image -> Int | 121 | bpp :: Image -> Int |
122 | bpp = fromIntegral . cbpp . imageData | 122 | bpp = fromIntegral . cbpp . imageData |
123 | 123 | ||
124 | -- | Return the given image's pixels. | 124 | -- | Return the given image's pixels. |
125 | pixels :: Image -> Ptr CUChar | 125 | pixels :: Image -> Ptr CUChar |
126 | pixels = cpixels . imageData | 126 | pixels = cpixels . imageData |
diff --git a/Spear/Assets/Image/Image.c b/Spear/Assets/Image/Image.c index 9abebe2..f4150e1 100644 --- a/Spear/Assets/Image/Image.c +++ b/Spear/Assets/Image/Image.c | |||
@@ -1,8 +1,8 @@ | |||
1 | #include "Image.h" | 1 | #include "Image.h" |
2 | #include <stdlib.h> | 2 | #include <stdlib.h> |
3 | 3 | ||
4 | 4 | ||
5 | void image_free (Image* image) | 5 | void image_free (Image* image) |
6 | { | 6 | { |
7 | free (image->pixels); | 7 | free (image->pixels); |
8 | } | 8 | } |
diff --git a/Spear/Assets/Image/Image.h b/Spear/Assets/Image/Image.h index bffdd97..aaca5e9 100644 --- a/Spear/Assets/Image/Image.h +++ b/Spear/Assets/Image/Image.h | |||
@@ -1,32 +1,32 @@ | |||
1 | #ifndef _SPEAR_IMAGE_H | 1 | #ifndef _SPEAR_IMAGE_H |
2 | #define _SPEAR_IMAGE_H | 2 | #define _SPEAR_IMAGE_H |
3 | 3 | ||
4 | #include "sys_types.h" | 4 | #include "sys_types.h" |
5 | 5 | ||
6 | 6 | ||
7 | typedef struct | 7 | typedef struct |
8 | { | 8 | { |
9 | int width; | 9 | int width; |
10 | int height; | 10 | int height; |
11 | int bpp; // Bits per pixel. | 11 | int bpp; // Bits per pixel. |
12 | // If bpp = 3 then format = RGB. | 12 | // If bpp = 3 then format = RGB. |
13 | // If bpp = 4 then format = RGBA. | 13 | // If bpp = 4 then format = RGBA. |
14 | U8* pixels; | 14 | U8* pixels; |
15 | } | 15 | } |
16 | Image; | 16 | Image; |
17 | 17 | ||
18 | 18 | ||
19 | #ifdef __cplusplus | 19 | #ifdef __cplusplus |
20 | extern "C" { | 20 | extern "C" { |
21 | #endif | 21 | #endif |
22 | 22 | ||
23 | /// Frees the given Image from memory. | 23 | /// Frees the given Image from memory. |
24 | /// The 'image' pointer itself is not freed. | 24 | /// The 'image' pointer itself is not freed. |
25 | void image_free (Image* image); | 25 | void image_free (Image* image); |
26 | 26 | ||
27 | #ifdef __cplusplus | 27 | #ifdef __cplusplus |
28 | } | 28 | } |
29 | #endif | 29 | #endif |
30 | 30 | ||
31 | 31 | ||
32 | #endif // _SPEAR_IMAGE_H | 32 | #endif // _SPEAR_IMAGE_H |
diff --git a/Spear/Assets/Image/Image_error_code.h b/Spear/Assets/Image/Image_error_code.h index 9e78aeb..dc54fc2 100644 --- a/Spear/Assets/Image/Image_error_code.h +++ b/Spear/Assets/Image/Image_error_code.h | |||
@@ -1,15 +1,15 @@ | |||
1 | #ifndef _SPEAR_IMAGE_ERROR_CODE_H | 1 | #ifndef _SPEAR_IMAGE_ERROR_CODE_H |
2 | #define _SPEAR_IMAGE_ERROR_CODE_H | 2 | #define _SPEAR_IMAGE_ERROR_CODE_H |
3 | 3 | ||
4 | typedef enum | 4 | typedef enum |
5 | { | 5 | { |
6 | Image_Success, | 6 | Image_Success, |
7 | Image_Read_Error, | 7 | Image_Read_Error, |
8 | Image_Memory_Allocation_Error, | 8 | Image_Memory_Allocation_Error, |
9 | Image_File_Not_Found, | 9 | Image_File_Not_Found, |
10 | Image_Invalid_Format, | 10 | Image_Invalid_Format, |
11 | Image_No_Suitable_Loader, | 11 | Image_No_Suitable_Loader, |
12 | } | 12 | } |
13 | Image_error_code; | 13 | Image_error_code; |
14 | 14 | ||
15 | #endif // _SPEAR_IMAGE_ERROR_CODE_H | 15 | #endif // _SPEAR_IMAGE_ERROR_CODE_H |
diff --git a/Spear/Assets/Image/sys_types.h b/Spear/Assets/Image/sys_types.h index e4eb251..6aca9e9 100644 --- a/Spear/Assets/Image/sys_types.h +++ b/Spear/Assets/Image/sys_types.h | |||
@@ -1,16 +1,16 @@ | |||
1 | #ifndef _SPEAR_SYS_TYPES_H | 1 | #ifndef _SPEAR_SYS_TYPES_H |
2 | #define _SPEAR_SYS_TYPES_H | 2 | #define _SPEAR_SYS_TYPES_H |
3 | 3 | ||
4 | #include <stdint.h> | 4 | #include <stdint.h> |
5 | 5 | ||
6 | typedef int8_t I8; | 6 | typedef int8_t I8; |
7 | typedef int16_t I16; | 7 | typedef int16_t I16; |
8 | typedef int32_t I32; | 8 | typedef int32_t I32; |
9 | typedef int64_t I64; | 9 | typedef int64_t I64; |
10 | typedef uint8_t U8; | 10 | typedef uint8_t U8; |
11 | typedef uint16_t U16; | 11 | typedef uint16_t U16; |
12 | typedef uint32_t U32; | 12 | typedef uint32_t U32; |
13 | typedef uint64_t U64; | 13 | typedef uint64_t U64; |
14 | 14 | ||
15 | #endif // _SPEAR_SYS_TYPES_H | 15 | #endif // _SPEAR_SYS_TYPES_H |
16 | 16 | ||
diff --git a/Spear/Assets/Model.hsc b/Spear/Assets/Model.hsc index 5e6e756..74666f2 100644 --- a/Spear/Assets/Model.hsc +++ b/Spear/Assets/Model.hsc | |||
@@ -1,440 +1,440 @@ | |||
1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} | 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} |
2 | 2 | ||
3 | module Spear.Assets.Model | 3 | module Spear.Assets.Model |
4 | ( | 4 | ( |
5 | -- * Data types | 5 | -- * Data types |
6 | Vec2(..) | 6 | Vec2(..) |
7 | , Vec3(..) | 7 | , Vec3(..) |
8 | , TexCoord(..) | 8 | , TexCoord(..) |
9 | , CTriangle(..) | 9 | , CTriangle(..) |
10 | , Box(..) | 10 | , Box(..) |
11 | , Skin(..) | 11 | , Skin(..) |
12 | , Animation(..) | 12 | , Animation(..) |
13 | , Triangle(..) | 13 | , Triangle(..) |
14 | , Model(..) | 14 | , Model(..) |
15 | -- * Loading | 15 | -- * Loading |
16 | , loadModel | 16 | , loadModel |
17 | -- * Accessors | 17 | -- * Accessors |
18 | , animated | 18 | , animated |
19 | , animation | 19 | , animation |
20 | , animationByName | 20 | , animationByName |
21 | , triangles' | 21 | , triangles' |
22 | -- * Manipulation | 22 | -- * Manipulation |
23 | , transformVerts | 23 | , transformVerts |
24 | , transformNormals | 24 | , transformNormals |
25 | , toGround | 25 | , toGround |
26 | , modelBoxes | 26 | , modelBoxes |
27 | ) | 27 | ) |
28 | where | 28 | where |
29 | 29 | ||
30 | import Spear.Game | 30 | import Spear.Game |
31 | 31 | ||
32 | import qualified Data.ByteString.Char8 as B | 32 | import qualified Data.ByteString.Char8 as B |
33 | import Data.Char (toLower) | 33 | import Data.Char (toLower) |
34 | import Data.List (splitAt, elemIndex) | 34 | import Data.List (splitAt, elemIndex) |
35 | import qualified Data.Vector as V | 35 | import qualified Data.Vector as V |
36 | import qualified Data.Vector.Storable as S | 36 | import qualified Data.Vector.Storable as S |
37 | import Foreign.Ptr | 37 | import Foreign.Ptr |
38 | import Foreign.Storable | 38 | import Foreign.Storable |
39 | import Foreign.C.Types | 39 | import Foreign.C.Types |
40 | import Foreign.C.String | 40 | import Foreign.C.String |
41 | import Foreign.Marshal.Utils as Foreign (with) | 41 | import Foreign.Marshal.Utils as Foreign (with) |
42 | import Foreign.Marshal.Alloc (alloca, allocaBytes) | 42 | import Foreign.Marshal.Alloc (alloca, allocaBytes) |
43 | import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) | 43 | import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) |
44 | import Unsafe.Coerce (unsafeCoerce) | 44 | import Unsafe.Coerce (unsafeCoerce) |
45 | 45 | ||
46 | #include "Model.h" | 46 | #include "Model.h" |
47 | #include "MD2/MD2_load.h" | 47 | #include "MD2/MD2_load.h" |
48 | #include "OBJ/OBJ_load.h" | 48 | #include "OBJ/OBJ_load.h" |
49 | 49 | ||
50 | data ModelErrorCode | 50 | data ModelErrorCode |
51 | = ModelSuccess | 51 | = ModelSuccess |
52 | | ModelReadError | 52 | | ModelReadError |
53 | | ModelMemoryAllocationError | 53 | | ModelMemoryAllocationError |
54 | | ModelFileNotFound | 54 | | ModelFileNotFound |
55 | | ModelFileMismatch | 55 | | ModelFileMismatch |
56 | | ModelNoSuitableLoader | 56 | | ModelNoSuitableLoader |
57 | deriving (Eq, Enum, Show) | 57 | deriving (Eq, Enum, Show) |
58 | 58 | ||
59 | sizeFloat = #{size float} | 59 | sizeFloat = #{size float} |
60 | sizePtr = #{size int*} | 60 | sizePtr = #{size int*} |
61 | 61 | ||
62 | -- | A 2D vector. | 62 | -- | A 2D vector. |
63 | data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float | 63 | data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float |
64 | 64 | ||
65 | instance Storable Vec2 where | 65 | instance Storable Vec2 where |
66 | sizeOf _ = 2*sizeFloat | 66 | sizeOf _ = 2*sizeFloat |
67 | alignment _ = alignment (undefined :: CFloat) | 67 | alignment _ = alignment (undefined :: CFloat) |
68 | 68 | ||
69 | peek ptr = do | 69 | peek ptr = do |
70 | f0 <- peekByteOff ptr 0 | 70 | f0 <- peekByteOff ptr 0 |
71 | f1 <- peekByteOff ptr sizeFloat | 71 | f1 <- peekByteOff ptr sizeFloat |
72 | return $ Vec2 f0 f1 | 72 | return $ Vec2 f0 f1 |
73 | 73 | ||
74 | poke ptr (Vec2 f0 f1) = do | 74 | poke ptr (Vec2 f0 f1) = do |
75 | pokeByteOff ptr 0 f0 | 75 | pokeByteOff ptr 0 f0 |
76 | pokeByteOff ptr sizeFloat f1 | 76 | pokeByteOff ptr sizeFloat f1 |
77 | 77 | ||
78 | -- | A 3D vector. | 78 | -- | A 3D vector. |
79 | data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float | 79 | data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float |
80 | 80 | ||
81 | instance Storable Vec3 where | 81 | instance Storable Vec3 where |
82 | sizeOf _ = 3*sizeFloat | 82 | sizeOf _ = 3*sizeFloat |
83 | alignment _ = alignment (undefined :: CFloat) | 83 | alignment _ = alignment (undefined :: CFloat) |
84 | 84 | ||
85 | peek ptr = do | 85 | peek ptr = do |
86 | f0 <- peekByteOff ptr 0 | 86 | f0 <- peekByteOff ptr 0 |
87 | f1 <- peekByteOff ptr sizeFloat | 87 | f1 <- peekByteOff ptr sizeFloat |
88 | f2 <- peekByteOff ptr (2*sizeFloat) | 88 | f2 <- peekByteOff ptr (2*sizeFloat) |
89 | return $ Vec3 f0 f1 f2 | 89 | return $ Vec3 f0 f1 f2 |
90 | 90 | ||
91 | poke ptr (Vec3 f0 f1 f2) = do | 91 | poke ptr (Vec3 f0 f1 f2) = do |
92 | pokeByteOff ptr 0 f0 | 92 | pokeByteOff ptr 0 f0 |
93 | pokeByteOff ptr sizeFloat f1 | 93 | pokeByteOff ptr sizeFloat f1 |
94 | pokeByteOff ptr (2*sizeFloat) f2 | 94 | pokeByteOff ptr (2*sizeFloat) f2 |
95 | 95 | ||
96 | -- | A 2D texture coordinate. | 96 | -- | A 2D texture coordinate. |
97 | data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float | 97 | data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float |
98 | 98 | ||
99 | instance Storable TexCoord where | 99 | instance Storable TexCoord where |
100 | sizeOf _ = 2*sizeFloat | 100 | sizeOf _ = 2*sizeFloat |
101 | alignment _ = alignment (undefined :: CFloat) | 101 | alignment _ = alignment (undefined :: CFloat) |
102 | 102 | ||
103 | peek ptr = do | 103 | peek ptr = do |
104 | f0 <- peekByteOff ptr 0 | 104 | f0 <- peekByteOff ptr 0 |
105 | f1 <- peekByteOff ptr sizeFloat | 105 | f1 <- peekByteOff ptr sizeFloat |
106 | return $ TexCoord f0 f1 | 106 | return $ TexCoord f0 f1 |
107 | 107 | ||
108 | poke ptr (TexCoord f0 f1) = do | 108 | poke ptr (TexCoord f0 f1) = do |
109 | pokeByteOff ptr 0 f0 | 109 | pokeByteOff ptr 0 f0 |
110 | pokeByteOff ptr sizeFloat f1 | 110 | pokeByteOff ptr sizeFloat f1 |
111 | 111 | ||
112 | -- | A raw triangle holding vertex/normal and texture indices. | 112 | -- | A raw triangle holding vertex/normal and texture indices. |
113 | data CTriangle = CTriangle | 113 | data CTriangle = CTriangle |
114 | { vertexIndex0 :: {-# UNPACK #-} !CUShort | 114 | { vertexIndex0 :: {-# UNPACK #-} !CUShort |
115 | , vertexIndex1 :: {-# UNPACK #-} !CUShort | 115 | , vertexIndex1 :: {-# UNPACK #-} !CUShort |
116 | , vertexIndex2 :: {-# UNPACK #-} !CUShort | 116 | , vertexIndex2 :: {-# UNPACK #-} !CUShort |
117 | , textureIndex1 :: {-# UNPACK #-} !CUShort | 117 | , textureIndex1 :: {-# UNPACK #-} !CUShort |
118 | , textureIndex2 :: {-# UNPACK #-} !CUShort | 118 | , textureIndex2 :: {-# UNPACK #-} !CUShort |
119 | , textureIndex3 :: {-# UNPACK #-} !CUShort | 119 | , textureIndex3 :: {-# UNPACK #-} !CUShort |
120 | } | 120 | } |
121 | 121 | ||
122 | instance Storable CTriangle where | 122 | instance Storable CTriangle where |
123 | sizeOf _ = #{size triangle} | 123 | sizeOf _ = #{size triangle} |
124 | alignment _ = alignment (undefined :: CUShort) | 124 | alignment _ = alignment (undefined :: CUShort) |
125 | 125 | ||
126 | peek ptr = do | 126 | peek ptr = do |
127 | v0 <- #{peek triangle, vertexIndices[0]} ptr | 127 | v0 <- #{peek triangle, vertexIndices[0]} ptr |
128 | v1 <- #{peek triangle, vertexIndices[1]} ptr | 128 | v1 <- #{peek triangle, vertexIndices[1]} ptr |
129 | v2 <- #{peek triangle, vertexIndices[2]} ptr | 129 | v2 <- #{peek triangle, vertexIndices[2]} ptr |
130 | 130 | ||
131 | t0 <- #{peek triangle, textureIndices[0]} ptr | 131 | t0 <- #{peek triangle, textureIndices[0]} ptr |
132 | t1 <- #{peek triangle, textureIndices[1]} ptr | 132 | t1 <- #{peek triangle, textureIndices[1]} ptr |
133 | t2 <- #{peek triangle, textureIndices[2]} ptr | 133 | t2 <- #{peek triangle, textureIndices[2]} ptr |
134 | 134 | ||
135 | return $ CTriangle v0 v1 v2 t0 t1 t2 | 135 | return $ CTriangle v0 v1 v2 t0 t1 t2 |
136 | 136 | ||
137 | poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do | 137 | poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do |
138 | #{poke triangle, vertexIndices[0]} ptr v0 | 138 | #{poke triangle, vertexIndices[0]} ptr v0 |
139 | #{poke triangle, vertexIndices[1]} ptr v1 | 139 | #{poke triangle, vertexIndices[1]} ptr v1 |
140 | #{poke triangle, vertexIndices[2]} ptr v2 | 140 | #{poke triangle, vertexIndices[2]} ptr v2 |
141 | 141 | ||
142 | #{poke triangle, textureIndices[0]} ptr t0 | 142 | #{poke triangle, textureIndices[0]} ptr t0 |
143 | #{poke triangle, textureIndices[1]} ptr t1 | 143 | #{poke triangle, textureIndices[1]} ptr t1 |
144 | #{poke triangle, textureIndices[2]} ptr t2 | 144 | #{poke triangle, textureIndices[2]} ptr t2 |
145 | 145 | ||
146 | -- | A 3D axis-aligned bounding box. | 146 | -- | A 3D axis-aligned bounding box. |
147 | data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 | 147 | data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 |
148 | 148 | ||
149 | instance Storable Box where | 149 | instance Storable Box where |
150 | sizeOf _ = 6 * sizeFloat | 150 | sizeOf _ = 6 * sizeFloat |
151 | alignment _ = alignment (undefined :: CFloat) | 151 | alignment _ = alignment (undefined :: CFloat) |
152 | 152 | ||
153 | peek ptr = do | 153 | peek ptr = do |
154 | xmin <- peekByteOff ptr 0 | 154 | xmin <- peekByteOff ptr 0 |
155 | ymin <- peekByteOff ptr sizeFloat | 155 | ymin <- peekByteOff ptr sizeFloat |
156 | zmin <- peekByteOff ptr $ 2*sizeFloat | 156 | zmin <- peekByteOff ptr $ 2*sizeFloat |
157 | xmax <- peekByteOff ptr $ 3*sizeFloat | 157 | xmax <- peekByteOff ptr $ 3*sizeFloat |
158 | ymax <- peekByteOff ptr $ 4*sizeFloat | 158 | ymax <- peekByteOff ptr $ 4*sizeFloat |
159 | zmax <- peekByteOff ptr $ 5*sizeFloat | 159 | zmax <- peekByteOff ptr $ 5*sizeFloat |
160 | return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax) | 160 | return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax) |
161 | 161 | ||
162 | poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do | 162 | poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do |
163 | pokeByteOff ptr 0 xmin | 163 | pokeByteOff ptr 0 xmin |
164 | pokeByteOff ptr sizeFloat ymin | 164 | pokeByteOff ptr sizeFloat ymin |
165 | pokeByteOff ptr (2*sizeFloat) zmin | 165 | pokeByteOff ptr (2*sizeFloat) zmin |
166 | pokeByteOff ptr (3*sizeFloat) xmax | 166 | pokeByteOff ptr (3*sizeFloat) xmax |
167 | pokeByteOff ptr (4*sizeFloat) ymax | 167 | pokeByteOff ptr (4*sizeFloat) ymax |
168 | pokeByteOff ptr (5*sizeFloat) zmax | 168 | pokeByteOff ptr (5*sizeFloat) zmax |
169 | 169 | ||
170 | -- | A model skin. | 170 | -- | A model skin. |
171 | newtype Skin = Skin { skinName :: B.ByteString } | 171 | newtype Skin = Skin { skinName :: B.ByteString } |
172 | 172 | ||
173 | instance Storable Skin where | 173 | instance Storable Skin where |
174 | sizeOf (Skin s) = 64 | 174 | sizeOf (Skin s) = 64 |
175 | alignment _ = 1 | 175 | alignment _ = 1 |
176 | 176 | ||
177 | peek ptr = do | 177 | peek ptr = do |
178 | s <- B.packCString $ unsafeCoerce ptr | 178 | s <- B.packCString $ unsafeCoerce ptr |
179 | return $ Skin s | 179 | return $ Skin s |
180 | 180 | ||
181 | poke ptr (Skin s) = do | 181 | poke ptr (Skin s) = do |
182 | B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len | 182 | B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len |
183 | 183 | ||
184 | -- | A model animation. | 184 | -- | A model animation. |
185 | -- | 185 | -- |
186 | -- See also: 'animation', 'animationByName', 'numAnimations'. | 186 | -- See also: 'animation', 'animationByName', 'numAnimations'. |
187 | data Animation = Animation | 187 | data Animation = Animation |
188 | { name :: B.ByteString | 188 | { name :: B.ByteString |
189 | , start :: Int | 189 | , start :: Int |
190 | , end :: Int | 190 | , end :: Int |
191 | } | 191 | } |
192 | 192 | ||
193 | instance Storable Animation where | 193 | instance Storable Animation where |
194 | sizeOf _ = #{size animation} | 194 | sizeOf _ = #{size animation} |
195 | alignment _ = alignment (undefined :: CUInt) | 195 | alignment _ = alignment (undefined :: CUInt) |
196 | 196 | ||
197 | peek ptr = do | 197 | peek ptr = do |
198 | name <- B.packCString (unsafeCoerce ptr) | 198 | name <- B.packCString (unsafeCoerce ptr) |
199 | start <- #{peek animation, start} ptr | 199 | start <- #{peek animation, start} ptr |
200 | end <- #{peek animation, end} ptr | 200 | end <- #{peek animation, end} ptr |
201 | return $ Animation name start end | 201 | return $ Animation name start end |
202 | 202 | ||
203 | poke ptr (Animation name start end) = do | 203 | poke ptr (Animation name start end) = do |
204 | B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len | 204 | B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len |
205 | #{poke animation, start} ptr start | 205 | #{poke animation, start} ptr start |
206 | #{poke animation, end} ptr end | 206 | #{poke animation, end} ptr end |
207 | 207 | ||
208 | -- | A 3D model. | 208 | -- | A 3D model. |
209 | data Model = Model | 209 | data Model = Model |
210 | { vertices :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' vertices. | 210 | { vertices :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' vertices. |
211 | , normals :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' normals. | 211 | , normals :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' normals. |
212 | , texCoords :: S.Vector TexCoord -- ^ Array of 'numTexCoords' texture coordinates. | 212 | , texCoords :: S.Vector TexCoord -- ^ Array of 'numTexCoords' texture coordinates. |
213 | , triangles :: S.Vector CTriangle -- ^ Array of 'numTriangles' triangles. | 213 | , triangles :: S.Vector CTriangle -- ^ Array of 'numTriangles' triangles. |
214 | , skins :: S.Vector Skin -- ^ Array of 'numSkins' skins. | 214 | , skins :: S.Vector Skin -- ^ Array of 'numSkins' skins. |
215 | , animations :: S.Vector Animation -- ^ Array of 'numAnimations' animations. | 215 | , animations :: S.Vector Animation -- ^ Array of 'numAnimations' animations. |
216 | , numFrames :: Int -- ^ Number of frames. | 216 | , numFrames :: Int -- ^ Number of frames. |
217 | , numVerts :: Int -- ^ Number of vertices (and normals) per frame. | 217 | , numVerts :: Int -- ^ Number of vertices (and normals) per frame. |
218 | , numTriangles :: Int -- ^ Number of triangles in one frame. | 218 | , numTriangles :: Int -- ^ Number of triangles in one frame. |
219 | , numTexCoords :: Int -- ^ Number of texture coordinates in one frame. | 219 | , numTexCoords :: Int -- ^ Number of texture coordinates in one frame. |
220 | , numSkins :: Int -- ^ Number of skins. | 220 | , numSkins :: Int -- ^ Number of skins. |
221 | , numAnimations :: Int -- ^ Number of animations. | 221 | , numAnimations :: Int -- ^ Number of animations. |
222 | } | 222 | } |
223 | 223 | ||
224 | instance Storable Model where | 224 | instance Storable Model where |
225 | sizeOf _ = #{size Model} | 225 | sizeOf _ = #{size Model} |
226 | alignment _ = alignment (undefined :: CUInt) | 226 | alignment _ = alignment (undefined :: CUInt) |
227 | 227 | ||
228 | peek ptr = do | 228 | peek ptr = do |
229 | numFrames <- #{peek Model, numFrames} ptr | 229 | numFrames <- #{peek Model, numFrames} ptr |
230 | numVertices <- #{peek Model, numVertices} ptr | 230 | numVertices <- #{peek Model, numVertices} ptr |
231 | numTriangles <- #{peek Model, numTriangles} ptr | 231 | numTriangles <- #{peek Model, numTriangles} ptr |
232 | numTexCoords <- #{peek Model, numTexCoords} ptr | 232 | numTexCoords <- #{peek Model, numTexCoords} ptr |
233 | numSkins <- #{peek Model, numSkins} ptr | 233 | numSkins <- #{peek Model, numSkins} ptr |
234 | numAnimations <- #{peek Model, numAnimations} ptr | 234 | numAnimations <- #{peek Model, numAnimations} ptr |
235 | pVerts <- peek (unsafeCoerce ptr) | 235 | pVerts <- peek (unsafeCoerce ptr) |
236 | pNormals <- peekByteOff ptr sizePtr | 236 | pNormals <- peekByteOff ptr sizePtr |
237 | pTexCoords <- peekByteOff ptr (2*sizePtr) | 237 | pTexCoords <- peekByteOff ptr (2*sizePtr) |
238 | pTriangles <- peekByteOff ptr (3*sizePtr) | 238 | pTriangles <- peekByteOff ptr (3*sizePtr) |
239 | pSkins <- peekByteOff ptr (4*sizePtr) | 239 | pSkins <- peekByteOff ptr (4*sizePtr) |
240 | pAnimations <- peekByteOff ptr (5*sizePtr) | 240 | pAnimations <- peekByteOff ptr (5*sizePtr) |
241 | vertices <- fmap S.fromList $ peekArray (numVertices*numFrames) pVerts | 241 | vertices <- fmap S.fromList $ peekArray (numVertices*numFrames) pVerts |
242 | normals <- fmap S.fromList $ peekArray (numVertices*numFrames) pNormals | 242 | normals <- fmap S.fromList $ peekArray (numVertices*numFrames) pNormals |
243 | texCoords <- fmap S.fromList $ peekArray numTexCoords pTexCoords | 243 | texCoords <- fmap S.fromList $ peekArray numTexCoords pTexCoords |
244 | triangles <- fmap S.fromList $ peekArray numTriangles pTriangles | 244 | triangles <- fmap S.fromList $ peekArray numTriangles pTriangles |
245 | skins <- fmap S.fromList $ peekArray numSkins pSkins | 245 | skins <- fmap S.fromList $ peekArray numSkins pSkins |
246 | animations <- fmap S.fromList $ peekArray numAnimations pAnimations | 246 | animations <- fmap S.fromList $ peekArray numAnimations pAnimations |
247 | return $ | 247 | return $ |
248 | Model vertices normals texCoords triangles skins animations | 248 | Model vertices normals texCoords triangles skins animations |
249 | numFrames numVertices numTriangles numTexCoords numSkins numAnimations | 249 | numFrames numVertices numTriangles numTexCoords numSkins numAnimations |
250 | 250 | ||
251 | poke ptr | 251 | poke ptr |
252 | (Model verts normals texCoords tris skins animations | 252 | (Model verts normals texCoords tris skins animations |
253 | numFrames numVerts numTris numTex numSkins numAnimations) = | 253 | numFrames numVerts numTris numTex numSkins numAnimations) = |
254 | S.unsafeWith verts $ \pVerts -> | 254 | S.unsafeWith verts $ \pVerts -> |
255 | S.unsafeWith normals $ \pNormals -> | 255 | S.unsafeWith normals $ \pNormals -> |
256 | S.unsafeWith texCoords $ \pTexCoords -> | 256 | S.unsafeWith texCoords $ \pTexCoords -> |
257 | S.unsafeWith tris $ \pTris -> | 257 | S.unsafeWith tris $ \pTris -> |
258 | S.unsafeWith skins $ \pSkins -> | 258 | S.unsafeWith skins $ \pSkins -> |
259 | S.unsafeWith animations $ \pAnimations -> do | 259 | S.unsafeWith animations $ \pAnimations -> do |
260 | #{poke Model, vertices} ptr pVerts | 260 | #{poke Model, vertices} ptr pVerts |
261 | #{poke Model, normals} ptr pNormals | 261 | #{poke Model, normals} ptr pNormals |
262 | #{poke Model, texCoords} ptr pTexCoords | 262 | #{poke Model, texCoords} ptr pTexCoords |
263 | #{poke Model, triangles} ptr pTris | 263 | #{poke Model, triangles} ptr pTris |
264 | #{poke Model, skins} ptr pSkins | 264 | #{poke Model, skins} ptr pSkins |
265 | #{poke Model, animations} ptr pAnimations | 265 | #{poke Model, animations} ptr pAnimations |
266 | #{poke Model, numFrames} ptr numFrames | 266 | #{poke Model, numFrames} ptr numFrames |
267 | #{poke Model, numVertices} ptr numVerts | 267 | #{poke Model, numVertices} ptr numVerts |
268 | #{poke Model, numTriangles} ptr numTris | 268 | #{poke Model, numTriangles} ptr numTris |
269 | #{poke Model, numTexCoords} ptr numTex | 269 | #{poke Model, numTexCoords} ptr numTex |
270 | #{poke Model, numSkins} ptr numSkins | 270 | #{poke Model, numSkins} ptr numSkins |
271 | #{poke Model, numAnimations} ptr numAnimations | 271 | #{poke Model, numAnimations} ptr numAnimations |
272 | 272 | ||
273 | -- | A model triangle. | 273 | -- | A model triangle. |
274 | -- | 274 | -- |
275 | -- See also: 'triangles''. | 275 | -- See also: 'triangles''. |
276 | data Triangle = Triangle | 276 | data Triangle = Triangle |
277 | { v0 :: Vec3 | 277 | { v0 :: Vec3 |
278 | , v1 :: Vec3 | 278 | , v1 :: Vec3 |
279 | , v2 :: Vec3 | 279 | , v2 :: Vec3 |
280 | , n0 :: Vec3 | 280 | , n0 :: Vec3 |
281 | , n1 :: Vec3 | 281 | , n1 :: Vec3 |
282 | , n2 :: Vec3 | 282 | , n2 :: Vec3 |
283 | , t0 :: TexCoord | 283 | , t0 :: TexCoord |
284 | , t1 :: TexCoord | 284 | , t1 :: TexCoord |
285 | , t2 :: TexCoord | 285 | , t2 :: TexCoord |
286 | } | 286 | } |
287 | 287 | ||
288 | instance Storable Triangle where | 288 | instance Storable Triangle where |
289 | sizeOf _ = #{size model_triangle} | 289 | sizeOf _ = #{size model_triangle} |
290 | alignment _ = alignment (undefined :: Float) | 290 | alignment _ = alignment (undefined :: Float) |
291 | 291 | ||
292 | peek ptr = do | 292 | peek ptr = do |
293 | v0 <- #{peek model_triangle, v0} ptr | 293 | v0 <- #{peek model_triangle, v0} ptr |
294 | v1 <- #{peek model_triangle, v1} ptr | 294 | v1 <- #{peek model_triangle, v1} ptr |
295 | v2 <- #{peek model_triangle, v2} ptr | 295 | v2 <- #{peek model_triangle, v2} ptr |
296 | n0 <- #{peek model_triangle, n0} ptr | 296 | n0 <- #{peek model_triangle, n0} ptr |
297 | n1 <- #{peek model_triangle, n1} ptr | 297 | n1 <- #{peek model_triangle, n1} ptr |
298 | n2 <- #{peek model_triangle, n2} ptr | 298 | n2 <- #{peek model_triangle, n2} ptr |
299 | t0 <- #{peek model_triangle, t0} ptr | 299 | t0 <- #{peek model_triangle, t0} ptr |
300 | t1 <- #{peek model_triangle, t1} ptr | 300 | t1 <- #{peek model_triangle, t1} ptr |
301 | t2 <- #{peek model_triangle, t2} ptr | 301 | t2 <- #{peek model_triangle, t2} ptr |
302 | return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2 | 302 | return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2 |
303 | 303 | ||
304 | poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do | 304 | poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do |
305 | #{poke model_triangle, v0} ptr v0 | 305 | #{poke model_triangle, v0} ptr v0 |
306 | #{poke model_triangle, v1} ptr v1 | 306 | #{poke model_triangle, v1} ptr v1 |
307 | #{poke model_triangle, v2} ptr v2 | 307 | #{poke model_triangle, v2} ptr v2 |
308 | #{poke model_triangle, n0} ptr n0 | 308 | #{poke model_triangle, n0} ptr n0 |
309 | #{poke model_triangle, n1} ptr n1 | 309 | #{poke model_triangle, n1} ptr n1 |
310 | #{poke model_triangle, n2} ptr n2 | 310 | #{poke model_triangle, n2} ptr n2 |
311 | #{poke model_triangle, t0} ptr t0 | 311 | #{poke model_triangle, t0} ptr t0 |
312 | #{poke model_triangle, t1} ptr t1 | 312 | #{poke model_triangle, t1} ptr t1 |
313 | #{poke model_triangle, t2} ptr t2 | 313 | #{poke model_triangle, t2} ptr t2 |
314 | 314 | ||
315 | foreign import ccall "Model.h model_free" | 315 | foreign import ccall "Model.h model_free" |
316 | model_free :: Ptr Model -> IO () | 316 | model_free :: Ptr Model -> IO () |
317 | 317 | ||
318 | foreign import ccall "MD2_load.h MD2_load" | 318 | foreign import ccall "MD2_load.h MD2_load" |
319 | md2_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int | 319 | md2_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int |
320 | 320 | ||
321 | foreign import ccall "OBJ_load.h OBJ_load" | 321 | foreign import ccall "OBJ_load.h OBJ_load" |
322 | obj_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int | 322 | obj_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int |
323 | 323 | ||
324 | md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode | 324 | md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode |
325 | md2_load file clockwise leftHanded model = | 325 | md2_load file clockwise leftHanded model = |
326 | md2_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code | 326 | md2_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code |
327 | 327 | ||
328 | obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode | 328 | obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode |
329 | obj_load file clockwise leftHanded model = | 329 | obj_load file clockwise leftHanded model = |
330 | obj_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code | 330 | obj_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code |
331 | 331 | ||
332 | -- | Load the model specified by the given file. | 332 | -- | Load the model specified by the given file. |
333 | loadModel :: FilePath -> Game s Model | 333 | loadModel :: FilePath -> Game s Model |
334 | loadModel file = do | 334 | loadModel file = do |
335 | dotPos <- case elemIndex '.' file of | 335 | dotPos <- case elemIndex '.' file of |
336 | Nothing -> gameError $ "file name has no extension: " ++ file | 336 | Nothing -> gameError $ "file name has no extension: " ++ file |
337 | Just p -> return p | 337 | Just p -> return p |
338 | 338 | ||
339 | let ext = map toLower . tail . snd $ splitAt dotPos file | 339 | let ext = map toLower . tail . snd $ splitAt dotPos file |
340 | 340 | ||
341 | result <- gameIO . alloca $ \ptr -> do | 341 | result <- gameIO . alloca $ \ptr -> do |
342 | status <- withCString file $ \fileCstr -> do | 342 | status <- withCString file $ \fileCstr -> do |
343 | case ext of | 343 | case ext of |
344 | "md2" -> md2_load fileCstr 0 0 ptr | 344 | "md2" -> md2_load fileCstr 0 0 ptr |
345 | "obj" -> obj_load fileCstr 0 0 ptr | 345 | "obj" -> obj_load fileCstr 0 0 ptr |
346 | _ -> return ModelNoSuitableLoader | 346 | _ -> return ModelNoSuitableLoader |
347 | 347 | ||
348 | case status of | 348 | case status of |
349 | ModelSuccess -> do | 349 | ModelSuccess -> do |
350 | model <- peek ptr | 350 | model <- peek ptr |
351 | model_free ptr | 351 | model_free ptr |
352 | return . Right $ model | 352 | return . Right $ model |
353 | ModelReadError -> return . Left $ "read error" | 353 | ModelReadError -> return . Left $ "read error" |
354 | ModelMemoryAllocationError -> return . Left $ "memory allocation error" | 354 | ModelMemoryAllocationError -> return . Left $ "memory allocation error" |
355 | ModelFileNotFound -> return . Left $ "file not found" | 355 | ModelFileNotFound -> return . Left $ "file not found" |
356 | ModelFileMismatch -> return . Left $ "file mismatch" | 356 | ModelFileMismatch -> return . Left $ "file mismatch" |
357 | ModelNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext | 357 | ModelNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext |
358 | 358 | ||
359 | case result of | 359 | case result of |
360 | Right model -> return model | 360 | Right model -> return model |
361 | Left err -> gameError $ "loadModel: " ++ err | 361 | Left err -> gameError $ "loadModel: " ++ err |
362 | 362 | ||
363 | -- | Return 'True' if the model is animated, 'False' otherwise. | 363 | -- | Return 'True' if the model is animated, 'False' otherwise. |
364 | animated :: Model -> Bool | 364 | animated :: Model -> Bool |
365 | animated = (>1) . numFrames | 365 | animated = (>1) . numFrames |
366 | 366 | ||
367 | -- | Return the model's ith animation. | 367 | -- | Return the model's ith animation. |
368 | animation :: Model -> Int -> Animation | 368 | animation :: Model -> Int -> Animation |
369 | animation model i = animations model S.! i | 369 | animation model i = animations model S.! i |
370 | 370 | ||
371 | -- | Return the animation specified by the given string. | 371 | -- | Return the animation specified by the given string. |
372 | animationByName :: Model -> String -> Maybe Animation | 372 | animationByName :: Model -> String -> Maybe Animation |
373 | animationByName model anim = | 373 | animationByName model anim = |
374 | let anim' = B.pack anim in S.find ((==) anim' . name) $ animations model | 374 | let anim' = B.pack anim in S.find ((==) anim' . name) $ animations model |
375 | 375 | ||
376 | -- | Return a copy of the model's triangles. | 376 | -- | Return a copy of the model's triangles. |
377 | triangles' :: Model -> IO [Triangle] | 377 | triangles' :: Model -> IO [Triangle] |
378 | triangles' model = | 378 | triangles' model = |
379 | let n = numVerts model * numFrames model | 379 | let n = numVerts model * numFrames model |
380 | in with model $ \modelPtr -> | 380 | in with model $ \modelPtr -> |
381 | allocaArray n $ \arrayPtr -> do | 381 | allocaArray n $ \arrayPtr -> do |
382 | model_copy_triangles modelPtr arrayPtr | 382 | model_copy_triangles modelPtr arrayPtr |
383 | tris <- peekArray n arrayPtr | 383 | tris <- peekArray n arrayPtr |
384 | return tris | 384 | return tris |
385 | 385 | ||
386 | foreign import ccall "Model.h model_copy_triangles" | 386 | foreign import ccall "Model.h model_copy_triangles" |
387 | model_copy_triangles :: Ptr Model -> Ptr Triangle -> IO () | 387 | model_copy_triangles :: Ptr Model -> Ptr Triangle -> IO () |
388 | 388 | ||
389 | -- | Transform the model's vertices. | 389 | -- | Transform the model's vertices. |
390 | transformVerts :: Model -> (Vec3 -> Vec3) -> Model | 390 | transformVerts :: Model -> (Vec3 -> Vec3) -> Model |
391 | transformVerts model f = model { vertices = vertices' } | 391 | transformVerts model f = model { vertices = vertices' } |
392 | where | 392 | where |
393 | n = numVerts model * numFrames model | 393 | n = numVerts model * numFrames model |
394 | vertices' = S.generate n f' | 394 | vertices' = S.generate n f' |
395 | f' i = f $ vertices model S.! i | 395 | f' i = f $ vertices model S.! i |
396 | 396 | ||
397 | -- | Transform the model's normals. | 397 | -- | Transform the model's normals. |
398 | transformNormals :: Model -> (Vec3 -> Vec3) -> Model | 398 | transformNormals :: Model -> (Vec3 -> Vec3) -> Model |
399 | transformNormals model f = model { normals = normals' } | 399 | transformNormals model f = model { normals = normals' } |
400 | where | 400 | where |
401 | n = numVerts model * numFrames model | 401 | n = numVerts model * numFrames model |
402 | normals' = S.generate n f' | 402 | normals' = S.generate n f' |
403 | f' i = f $ normals model S.! i | 403 | f' i = f $ normals model S.! i |
404 | 404 | ||
405 | -- | Translate the model such that its lowest point has y = 0. | 405 | -- | Translate the model such that its lowest point has y = 0. |
406 | toGround :: Model -> IO Model | 406 | toGround :: Model -> IO Model |
407 | toGround model = | 407 | toGround model = |
408 | let model' = model { vertices = S.generate n $ \i -> vertices model S.! i } | 408 | let model' = model { vertices = S.generate n $ \i -> vertices model S.! i } |
409 | n = numVerts model * numFrames model | 409 | n = numVerts model * numFrames model |
410 | in | 410 | in |
411 | with model' model_to_ground >> return model' | 411 | with model' model_to_ground >> return model' |
412 | 412 | ||
413 | foreign import ccall "Model.h model_to_ground" | 413 | foreign import ccall "Model.h model_to_ground" |
414 | model_to_ground :: Ptr Model -> IO () | 414 | model_to_ground :: Ptr Model -> IO () |
415 | 415 | ||
416 | -- | Get the model's 3D bounding boxes. | 416 | -- | Get the model's 3D bounding boxes. |
417 | modelBoxes :: Model -> IO (V.Vector Box) | 417 | modelBoxes :: Model -> IO (V.Vector Box) |
418 | modelBoxes model = | 418 | modelBoxes model = |
419 | with model $ \modelPtr -> | 419 | with model $ \modelPtr -> |
420 | allocaArray (numVerts model * numFrames model * 6) $ \pointsPtr -> do | 420 | allocaArray (numVerts model * numFrames model * 6) $ \pointsPtr -> do |
421 | model_compute_boxes modelPtr pointsPtr | 421 | model_compute_boxes modelPtr pointsPtr |
422 | let n = numFrames model | 422 | let n = numFrames model |
423 | getBoxes = peekBoxes pointsPtr n 0 0 $ return [] | 423 | getBoxes = peekBoxes pointsPtr n 0 0 $ return [] |
424 | peekBoxes ptr n cur off l | 424 | peekBoxes ptr n cur off l |
425 | | cur == n = l | 425 | | cur == n = l |
426 | | otherwise = do | 426 | | otherwise = do |
427 | xmin <- peekByteOff ptr off | 427 | xmin <- peekByteOff ptr off |
428 | ymin <- peekByteOff ptr $ off + sizeFloat | 428 | ymin <- peekByteOff ptr $ off + sizeFloat |
429 | zmin <- peekByteOff ptr $ off + 2*sizeFloat | 429 | zmin <- peekByteOff ptr $ off + 2*sizeFloat |
430 | xmax <- peekByteOff ptr $ off + 3*sizeFloat | 430 | xmax <- peekByteOff ptr $ off + 3*sizeFloat |
431 | ymax <- peekByteOff ptr $ off + 4*sizeFloat | 431 | ymax <- peekByteOff ptr $ off + 4*sizeFloat |
432 | zmax <- peekByteOff ptr $ off + 5*sizeFloat | 432 | zmax <- peekByteOff ptr $ off + 5*sizeFloat |
433 | let pmin = Vec3 xmin ymin zmin | 433 | let pmin = Vec3 xmin ymin zmin |
434 | pmax = Vec3 xmax ymax zmax | 434 | pmax = Vec3 xmax ymax zmax |
435 | box = Box pmin pmax | 435 | box = Box pmin pmax |
436 | peekBoxes ptr n (cur+1) (off + 6*sizeFloat) $ fmap (box:) l | 436 | peekBoxes ptr n (cur+1) (off + 6*sizeFloat) $ fmap (box:) l |
437 | fmap (V.fromList . reverse) getBoxes | 437 | fmap (V.fromList . reverse) getBoxes |
438 | 438 | ||
439 | foreign import ccall "Model.h model_compute_boxes" | 439 | foreign import ccall "Model.h model_compute_boxes" |
440 | model_compute_boxes :: Ptr Model -> Ptr Vec2 -> IO () | 440 | model_compute_boxes :: Ptr Model -> Ptr Vec2 -> IO () |
diff --git a/Spear/Assets/Model/MD2/MD2_load.c b/Spear/Assets/Model/MD2/MD2_load.c index 86d6f6d..92b1ac2 100644 --- a/Spear/Assets/Model/MD2/MD2_load.c +++ b/Spear/Assets/Model/MD2/MD2_load.c | |||
@@ -1,480 +1,480 @@ | |||
1 | #include "MD2_load.h" | 1 | #include "MD2_load.h" |
2 | #include <stdio.h> | 2 | #include <stdio.h> |
3 | #include <string.h> | 3 | #include <string.h> |
4 | #include <stdlib.h> // malloc | 4 | #include <stdlib.h> // malloc |
5 | #include <math.h> // sqrt | 5 | #include <math.h> // sqrt |
6 | 6 | ||
7 | //! The MD2 magic number used to identify MD2 files. | 7 | //! The MD2 magic number used to identify MD2 files. |
8 | #define MD2_ID 0x32504449 | 8 | #define MD2_ID 0x32504449 |
9 | 9 | ||
10 | //! Limit values for the MD2 file format. | 10 | //! Limit values for the MD2 file format. |
11 | #define MD2_MAX_TRIANGLES 4096 | 11 | #define MD2_MAX_TRIANGLES 4096 |
12 | #define MD2_MAX_VERTICES 2048 | 12 | #define MD2_MAX_VERTICES 2048 |
13 | #define MD2_MAX_TEXCOORDS 2048 | 13 | #define MD2_MAX_TEXCOORDS 2048 |
14 | #define MD2_MAX_FRAMES 512 | 14 | #define MD2_MAX_FRAMES 512 |
15 | #define MD2_MAX_SKINS 32 | 15 | #define MD2_MAX_SKINS 32 |
16 | 16 | ||
17 | 17 | ||
18 | /// MD2 file header. | 18 | /// MD2 file header. |
19 | typedef struct | 19 | typedef struct |
20 | { | 20 | { |
21 | I32 magic; /// The magic number "IDP2"; 844121161 in decimal; 0x32504449 | 21 | I32 magic; /// The magic number "IDP2"; 844121161 in decimal; 0x32504449 |
22 | I32 version; /// Version number, always 8. | 22 | I32 version; /// Version number, always 8. |
23 | I32 skinWidth; /// Width of the skin(s) in pixels. | 23 | I32 skinWidth; /// Width of the skin(s) in pixels. |
24 | I32 skinHeight; /// Height of the skin(s) in pixels. | 24 | I32 skinHeight; /// Height of the skin(s) in pixels. |
25 | I32 frameSize; /// Size of a single frame in bytes. | 25 | I32 frameSize; /// Size of a single frame in bytes. |
26 | I32 numSkins; /// Number of skins. | 26 | I32 numSkins; /// Number of skins. |
27 | I32 numVertices; /// Number of vertices in a single frame. | 27 | I32 numVertices; /// Number of vertices in a single frame. |
28 | I32 numTexCoords; /// Number of texture coordinates. | 28 | I32 numTexCoords; /// Number of texture coordinates. |
29 | I32 numTriangles; /// Number of triangles. | 29 | I32 numTriangles; /// Number of triangles. |
30 | I32 numGlCommands; /// Number of dwords in the Gl command list. | 30 | I32 numGlCommands; /// Number of dwords in the Gl command list. |
31 | I32 numFrames; /// Number of frames. | 31 | I32 numFrames; /// Number of frames. |
32 | I32 offsetSkins; /// Offset from the start of the file to the array of skins. | 32 | I32 offsetSkins; /// Offset from the start of the file to the array of skins. |
33 | I32 offsetTexCoords; /// Offset from the start of the file to the array of texture coordinates. | 33 | I32 offsetTexCoords; /// Offset from the start of the file to the array of texture coordinates. |
34 | I32 offsetTriangles; /// Offset from the start of the file to the array of triangles. | 34 | I32 offsetTriangles; /// Offset from the start of the file to the array of triangles. |
35 | I32 offsetFrames; /// Offset from the start of the file to the array of frames. | 35 | I32 offsetFrames; /// Offset from the start of the file to the array of frames. |
36 | I32 offsetGlCommands; /// Offset from the start of the file to the array of Gl commands. | 36 | I32 offsetGlCommands; /// Offset from the start of the file to the array of Gl commands. |
37 | I32 offsetEnd; /// Offset from the start of the file to the end of the file (the file size). | 37 | I32 offsetEnd; /// Offset from the start of the file to the end of the file (the file size). |
38 | } | 38 | } |
39 | md2Header_t; | 39 | md2Header_t; |
40 | 40 | ||
41 | 41 | ||
42 | /// Represents a texture coordinate index. | 42 | /// Represents a texture coordinate index. |
43 | typedef struct | 43 | typedef struct |
44 | { | 44 | { |
45 | I16 s; | 45 | I16 s; |
46 | I16 t; | 46 | I16 t; |
47 | } | 47 | } |
48 | texCoord_t; | 48 | texCoord_t; |
49 | 49 | ||
50 | 50 | ||
51 | /// Represents a frame point. | 51 | /// Represents a frame point. |
52 | typedef struct | 52 | typedef struct |
53 | { | 53 | { |
54 | U8 x, y, z; | 54 | U8 x, y, z; |
55 | U8 lightNormalIndex; | 55 | U8 lightNormalIndex; |
56 | } | 56 | } |
57 | vertex_t; | 57 | vertex_t; |
58 | 58 | ||
59 | 59 | ||
60 | /// Represents a single frame. | 60 | /// Represents a single frame. |
61 | typedef struct | 61 | typedef struct |
62 | { | 62 | { |
63 | vec3 scale; | 63 | vec3 scale; |
64 | vec3 translate; | 64 | vec3 translate; |
65 | I8 name[16]; | 65 | I8 name[16]; |
66 | vertex_t vertices[1]; | 66 | vertex_t vertices[1]; |
67 | } | 67 | } |
68 | frame_t; | 68 | frame_t; |
69 | 69 | ||
70 | 70 | ||
71 | static void normalise (vec3* v) | 71 | static void normalise (vec3* v) |
72 | { | 72 | { |
73 | float x = v->x; | 73 | float x = v->x; |
74 | float y = v->y; | 74 | float y = v->y; |
75 | float z = v->z; | 75 | float z = v->z; |
76 | float mag = sqrt (x*x + y*y + z*z); | 76 | float mag = sqrt (x*x + y*y + z*z); |
77 | mag = mag == 0 ? 1 : mag; | 77 | mag = mag == 0 ? 1 : mag; |
78 | v->x = x / mag; | 78 | v->x = x / mag; |
79 | v->y = y / mag; | 79 | v->y = y / mag; |
80 | v->z = z / mag; | 80 | v->z = z / mag; |
81 | } | 81 | } |
82 | 82 | ||
83 | 83 | ||
84 | static void cross (const vec3* a, const vec3* b, vec3* c) | 84 | static void cross (const vec3* a, const vec3* b, vec3* c) |
85 | { | 85 | { |
86 | c->x = a->y * b->z - a->z * b->y; | 86 | c->x = a->y * b->z - a->z * b->y; |
87 | c->y = a->z * b->x - a->x * b->z; | 87 | c->y = a->z * b->x - a->x * b->z; |
88 | c->z = a->x * b->y - a->y * b->x; | 88 | c->z = a->x * b->y - a->y * b->x; |
89 | } | 89 | } |
90 | 90 | ||
91 | 91 | ||
92 | static void vec3_sub (const vec3* a, const vec3* b, vec3* out) | 92 | static void vec3_sub (const vec3* a, const vec3* b, vec3* out) |
93 | { | 93 | { |
94 | out->x = a->x - b->x; | 94 | out->x = a->x - b->x; |
95 | out->y = a->y - b->y; | 95 | out->y = a->y - b->y; |
96 | out->z = a->z - b->z; | 96 | out->z = a->z - b->z; |
97 | } | 97 | } |
98 | 98 | ||
99 | 99 | ||
100 | static void normal (char clockwise, const vec3* p1, const vec3* p2, const vec3* p3, vec3* n) | 100 | static void normal (char clockwise, const vec3* p1, const vec3* p2, const vec3* p3, vec3* n) |
101 | { | 101 | { |
102 | vec3 v1, v2; | 102 | vec3 v1, v2; |
103 | if (clockwise) | 103 | if (clockwise) |
104 | { | 104 | { |
105 | vec3_sub (p3, p2, &v1); | 105 | vec3_sub (p3, p2, &v1); |
106 | vec3_sub (p1, p2, &v2); | 106 | vec3_sub (p1, p2, &v2); |
107 | } | 107 | } |
108 | else | 108 | else |
109 | { | 109 | { |
110 | vec3_sub (p1, p2, &v1); | 110 | vec3_sub (p1, p2, &v1); |
111 | vec3_sub (p3, p2, &v2); | 111 | vec3_sub (p3, p2, &v2); |
112 | } | 112 | } |
113 | cross (&v1, &v2, n); | 113 | cross (&v1, &v2, n); |
114 | normalise (n); | 114 | normalise (n); |
115 | } | 115 | } |
116 | 116 | ||
117 | 117 | ||
118 | typedef struct | 118 | typedef struct |
119 | { | 119 | { |
120 | vec3* normals; | 120 | vec3* normals; |
121 | vec3* base; | 121 | vec3* base; |
122 | unsigned int N; | 122 | unsigned int N; |
123 | } | 123 | } |
124 | normal_map; | 124 | normal_map; |
125 | 125 | ||
126 | 126 | ||
127 | static void normal_map_initialise (normal_map* m, unsigned int N) | 127 | static void normal_map_initialise (normal_map* m, unsigned int N) |
128 | { | 128 | { |
129 | m->N = N; | 129 | m->N = N; |
130 | } | 130 | } |
131 | 131 | ||
132 | 132 | ||
133 | static void normal_map_clear (normal_map* m, vec3* normals, vec3* base) | 133 | static void normal_map_clear (normal_map* m, vec3* normals, vec3* base) |
134 | { | 134 | { |
135 | memset (normals, 0, m->N * sizeof(vec3)); | 135 | memset (normals, 0, m->N * sizeof(vec3)); |
136 | m->normals = normals; | 136 | m->normals = normals; |
137 | m->base = base; | 137 | m->base = base; |
138 | } | 138 | } |
139 | 139 | ||
140 | 140 | ||
141 | static void normal_map_insert (normal_map* m, vec3* vec, vec3 normal) | 141 | static void normal_map_insert (normal_map* m, vec3* vec, vec3 normal) |
142 | { | 142 | { |
143 | unsigned int i = vec - m->base; | 143 | unsigned int i = vec - m->base; |
144 | vec3* n = m->normals + i; | 144 | vec3* n = m->normals + i; |
145 | n->x += normal.x; | 145 | n->x += normal.x; |
146 | n->y += normal.y; | 146 | n->y += normal.y; |
147 | n->z += normal.z; | 147 | n->z += normal.z; |
148 | } | 148 | } |
149 | 149 | ||
150 | 150 | ||
151 | static void compute_normals (normal_map* m, char left_handed) | 151 | static void compute_normals (normal_map* m, char left_handed) |
152 | { | 152 | { |
153 | vec3* n = m->normals; | 153 | vec3* n = m->normals; |
154 | unsigned int i; | 154 | unsigned int i; |
155 | for (i = 0; i < m->N; ++i) | 155 | for (i = 0; i < m->N; ++i) |
156 | { | 156 | { |
157 | if (!left_handed) | 157 | if (!left_handed) |
158 | { | 158 | { |
159 | n->x = -n->x; | 159 | n->x = -n->x; |
160 | n->y = -n->y; | 160 | n->y = -n->y; |
161 | n->z = -n->z; | 161 | n->z = -n->z; |
162 | } | 162 | } |
163 | normalise (n); | 163 | normalise (n); |
164 | n++; | 164 | n++; |
165 | } | 165 | } |
166 | } | 166 | } |
167 | 167 | ||
168 | 168 | ||
169 | static void safe_free (void* ptr) | 169 | static void safe_free (void* ptr) |
170 | { | 170 | { |
171 | if (ptr) free (ptr); | 171 | if (ptr) free (ptr); |
172 | } | 172 | } |
173 | 173 | ||
174 | 174 | ||
175 | static char frame_equal (const char* name1, const char* name2) | 175 | static char frame_equal (const char* name1, const char* name2) |
176 | { | 176 | { |
177 | char equal = 1; | 177 | char equal = 1; |
178 | int i; | 178 | int i; |
179 | 179 | ||
180 | if (((name1 == 0) && (name2 != 0)) || ((name1 != 0) && (name2 == 0))) | 180 | if (((name1 == 0) && (name2 != 0)) || ((name1 != 0) && (name2 == 0))) |
181 | { | 181 | { |
182 | return 0; | 182 | return 0; |
183 | } | 183 | } |
184 | 184 | ||
185 | for (i = 0; i < 16; ++i) | 185 | for (i = 0; i < 16; ++i) |
186 | { | 186 | { |
187 | char c1 = *name1; | 187 | char c1 = *name1; |
188 | char c2 = *name2; | 188 | char c2 = *name2; |
189 | if ((c1 >= '0' && c1 <= '9') || (c2 >= '0' && c2 <= '9')) break; | 189 | if ((c1 >= '0' && c1 <= '9') || (c2 >= '0' && c2 <= '9')) break; |
190 | if (c1 != c2) | 190 | if (c1 != c2) |
191 | { | 191 | { |
192 | equal = 0; | 192 | equal = 0; |
193 | break; | 193 | break; |
194 | } | 194 | } |
195 | if (c1 == '_' || c2 == '_') break; | 195 | if (c1 == '_' || c2 == '_') break; |
196 | name1++; | 196 | name1++; |
197 | name2++; | 197 | name2++; |
198 | } | 198 | } |
199 | return equal; | 199 | return equal; |
200 | } | 200 | } |
201 | 201 | ||
202 | 202 | ||
203 | static void animation_remove_numbers (char* name) | 203 | static void animation_remove_numbers (char* name) |
204 | { | 204 | { |
205 | int i; | 205 | int i; |
206 | for (i = 0; i < 16; ++i) | 206 | for (i = 0; i < 16; ++i) |
207 | { | 207 | { |
208 | char c = *name; | 208 | char c = *name; |
209 | if (c == 0) break; | 209 | if (c == 0) break; |
210 | if (c >= '0' && c <= '9') *name = 0; | 210 | if (c >= '0' && c <= '9') *name = 0; |
211 | name++; | 211 | name++; |
212 | } | 212 | } |
213 | } | 213 | } |
214 | 214 | ||
215 | 215 | ||
216 | Model_error_code MD2_load (const char* filename, char clockwise, char left_handed, Model* model) | 216 | Model_error_code MD2_load (const char* filename, char clockwise, char left_handed, Model* model) |
217 | { | 217 | { |
218 | FILE* filePtr; | 218 | FILE* filePtr; |
219 | vec3* vertices; | 219 | vec3* vertices; |
220 | vec3* normals; | 220 | vec3* normals; |
221 | texCoord* texCoords; | 221 | texCoord* texCoords; |
222 | triangle* triangles; | 222 | triangle* triangles; |
223 | skin* skins; | 223 | skin* skins; |
224 | animation* animations; | 224 | animation* animations; |
225 | int i; | 225 | int i; |
226 | 226 | ||
227 | // Open the file for reading. | 227 | // Open the file for reading. |
228 | filePtr = fopen(filename, "rb"); | 228 | filePtr = fopen(filename, "rb"); |
229 | if (!filePtr) return Model_File_Not_Found; | 229 | if (!filePtr) return Model_File_Not_Found; |
230 | 230 | ||
231 | // Make sure it is an MD2 file. | 231 | // Make sure it is an MD2 file. |
232 | int magic; | 232 | int magic; |
233 | if ((fread(&magic, 4, 1, filePtr)) != 1) | 233 | if ((fread(&magic, 4, 1, filePtr)) != 1) |
234 | { | 234 | { |
235 | fclose(filePtr); | 235 | fclose(filePtr); |
236 | return Model_Read_Error; | 236 | return Model_Read_Error; |
237 | } | 237 | } |
238 | 238 | ||
239 | if (magic != MD2_ID) return Model_File_Mismatch; | 239 | if (magic != MD2_ID) return Model_File_Mismatch; |
240 | 240 | ||
241 | // Find out the file size. | 241 | // Find out the file size. |
242 | long int fileSize; | 242 | long int fileSize; |
243 | fseek(filePtr, 0, SEEK_END); | 243 | fseek(filePtr, 0, SEEK_END); |
244 | fileSize = ftell(filePtr); | 244 | fileSize = ftell(filePtr); |
245 | fseek(filePtr, 0, SEEK_SET); | 245 | fseek(filePtr, 0, SEEK_SET); |
246 | 246 | ||
247 | // Allocate a chunk of data to store the file in. | 247 | // Allocate a chunk of data to store the file in. |
248 | char *buffer = (char*) malloc(fileSize); | 248 | char *buffer = (char*) malloc(fileSize); |
249 | if (!buffer) | 249 | if (!buffer) |
250 | { | 250 | { |
251 | fclose(filePtr); | 251 | fclose(filePtr); |
252 | return Model_Memory_Allocation_Error; | 252 | return Model_Memory_Allocation_Error; |
253 | } | 253 | } |
254 | 254 | ||
255 | // Read the entire file into memory. | 255 | // Read the entire file into memory. |
256 | if ((fread(buffer, 1, fileSize, filePtr)) != (unsigned int)fileSize) | 256 | if ((fread(buffer, 1, fileSize, filePtr)) != (unsigned int)fileSize) |
257 | { | 257 | { |
258 | fclose(filePtr); | 258 | fclose(filePtr); |
259 | free(buffer); | 259 | free(buffer); |
260 | return Model_Read_Error; | 260 | return Model_Read_Error; |
261 | } | 261 | } |
262 | 262 | ||
263 | // File stream is no longer needed. | 263 | // File stream is no longer needed. |
264 | fclose(filePtr); | 264 | fclose(filePtr); |
265 | 265 | ||
266 | // Set a pointer to the header for parsing. | 266 | // Set a pointer to the header for parsing. |
267 | md2Header_t* header = (md2Header_t*) buffer; | 267 | md2Header_t* header = (md2Header_t*) buffer; |
268 | 268 | ||
269 | // Compute the number of animations. | 269 | // Compute the number of animations. |
270 | unsigned numAnimations = 1; | 270 | unsigned numAnimations = 1; |
271 | int currentFrame; | 271 | int currentFrame; |
272 | const char* name = 0; | 272 | const char* name = 0; |
273 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) | 273 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) |
274 | { | 274 | { |
275 | frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; | 275 | frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; |
276 | if (name == 0) | 276 | if (name == 0) |
277 | { | 277 | { |
278 | name = frame->name; | 278 | name = frame->name; |
279 | } | 279 | } |
280 | else if (!frame_equal(name, frame->name)) | 280 | else if (!frame_equal(name, frame->name)) |
281 | { | 281 | { |
282 | numAnimations++; | 282 | numAnimations++; |
283 | name = frame->name; | 283 | name = frame->name; |
284 | } | 284 | } |
285 | } | 285 | } |
286 | 286 | ||
287 | // Allocate memory for arrays. | 287 | // Allocate memory for arrays. |
288 | vertices = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); | 288 | vertices = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); |
289 | normals = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); | 289 | normals = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); |
290 | texCoords = (texCoord*) malloc(sizeof(texCoord) * header->numTexCoords); | 290 | texCoords = (texCoord*) malloc(sizeof(texCoord) * header->numTexCoords); |
291 | triangles = (triangle*) malloc(sizeof(triangle) * header->numTriangles); | 291 | triangles = (triangle*) malloc(sizeof(triangle) * header->numTriangles); |
292 | skins = (skin*) malloc(sizeof(skin) * header->numSkins); | 292 | skins = (skin*) malloc(sizeof(skin) * header->numSkins); |
293 | animations = (animation*) malloc (numAnimations * sizeof(animation)); | 293 | animations = (animation*) malloc (numAnimations * sizeof(animation)); |
294 | 294 | ||
295 | if (!vertices || !normals || !texCoords || !triangles || !skins || !animations) | 295 | if (!vertices || !normals || !texCoords || !triangles || !skins || !animations) |
296 | { | 296 | { |
297 | safe_free (animations); | 297 | safe_free (animations); |
298 | safe_free (skins); | 298 | safe_free (skins); |
299 | safe_free (triangles); | 299 | safe_free (triangles); |
300 | safe_free (texCoords); | 300 | safe_free (texCoords); |
301 | safe_free (normals); | 301 | safe_free (normals); |
302 | safe_free (vertices); | 302 | safe_free (vertices); |
303 | free (buffer); | 303 | free (buffer); |
304 | return Model_Memory_Allocation_Error; | 304 | return Model_Memory_Allocation_Error; |
305 | } | 305 | } |
306 | 306 | ||
307 | // Load the model's vertices. | 307 | // Load the model's vertices. |
308 | // Loop through each frame, grab the vertices that make it up, transform them back | 308 | // Loop through each frame, grab the vertices that make it up, transform them back |
309 | // to their real coordinates and store them in the model's vertex array. | 309 | // to their real coordinates and store them in the model's vertex array. |
310 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) | 310 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) |
311 | { | 311 | { |
312 | // Set a frame pointer to the current frame. | 312 | // Set a frame pointer to the current frame. |
313 | frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; | 313 | frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; |
314 | 314 | ||
315 | // Set a vertex pointer to the model's vertex array, at the appropiate position. | 315 | // Set a vertex pointer to the model's vertex array, at the appropiate position. |
316 | vec3* vert = &vertices[currentFrame * header->numVertices]; | 316 | vec3* vert = &vertices[currentFrame * header->numVertices]; |
317 | 317 | ||
318 | // Now parse those vertices and transform them back. | 318 | // Now parse those vertices and transform them back. |
319 | int currentVertex; | 319 | int currentVertex; |
320 | for (currentVertex = 0; currentVertex != header->numVertices; ++currentVertex) | 320 | for (currentVertex = 0; currentVertex != header->numVertices; ++currentVertex) |
321 | { | 321 | { |
322 | vert[currentVertex].x = frame->vertices[currentVertex].x * frame->scale.x + frame->translate.x; | 322 | vert[currentVertex].x = frame->vertices[currentVertex].x * frame->scale.x + frame->translate.x; |
323 | vert[currentVertex].y = frame->vertices[currentVertex].y * frame->scale.y + frame->translate.y; | 323 | vert[currentVertex].y = frame->vertices[currentVertex].y * frame->scale.y + frame->translate.y; |
324 | vert[currentVertex].z = frame->vertices[currentVertex].z * frame->scale.z + frame->translate.z; | 324 | vert[currentVertex].z = frame->vertices[currentVertex].z * frame->scale.z + frame->translate.z; |
325 | } | 325 | } |
326 | } | 326 | } |
327 | 327 | ||
328 | // Load the model's triangles. | 328 | // Load the model's triangles. |
329 | 329 | ||
330 | // Set a pointer to the triangles array in the buffer. | 330 | // Set a pointer to the triangles array in the buffer. |
331 | triangle* t = (triangle*) &buffer[header->offsetTriangles]; | 331 | triangle* t = (triangle*) &buffer[header->offsetTriangles]; |
332 | 332 | ||
333 | if (clockwise) | 333 | if (clockwise) |
334 | { | 334 | { |
335 | for (i = 0; i < header->numTriangles; ++i) | 335 | for (i = 0; i < header->numTriangles; ++i) |
336 | { | 336 | { |
337 | triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; | 337 | triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; |
338 | triangles[i].vertexIndices[1] = t[i].vertexIndices[1]; | 338 | triangles[i].vertexIndices[1] = t[i].vertexIndices[1]; |
339 | triangles[i].vertexIndices[2] = t[i].vertexIndices[2]; | 339 | triangles[i].vertexIndices[2] = t[i].vertexIndices[2]; |
340 | 340 | ||
341 | triangles[i].textureIndices[0] = t[i].textureIndices[0]; | 341 | triangles[i].textureIndices[0] = t[i].textureIndices[0]; |
342 | triangles[i].textureIndices[1] = t[i].textureIndices[1]; | 342 | triangles[i].textureIndices[1] = t[i].textureIndices[1]; |
343 | triangles[i].textureIndices[2] = t[i].textureIndices[2]; | 343 | triangles[i].textureIndices[2] = t[i].textureIndices[2]; |
344 | } | 344 | } |
345 | } | 345 | } |
346 | else | 346 | else |
347 | { | 347 | { |
348 | for (i = 0; i < header->numTriangles; ++i) | 348 | for (i = 0; i < header->numTriangles; ++i) |
349 | { | 349 | { |
350 | triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; | 350 | triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; |
351 | triangles[i].vertexIndices[1] = t[i].vertexIndices[2]; | 351 | triangles[i].vertexIndices[1] = t[i].vertexIndices[2]; |
352 | triangles[i].vertexIndices[2] = t[i].vertexIndices[1]; | 352 | triangles[i].vertexIndices[2] = t[i].vertexIndices[1]; |
353 | 353 | ||
354 | triangles[i].textureIndices[0] = t[i].textureIndices[0]; | 354 | triangles[i].textureIndices[0] = t[i].textureIndices[0]; |
355 | triangles[i].textureIndices[1] = t[i].textureIndices[2]; | 355 | triangles[i].textureIndices[1] = t[i].textureIndices[2]; |
356 | triangles[i].textureIndices[2] = t[i].textureIndices[1]; | 356 | triangles[i].textureIndices[2] = t[i].textureIndices[1]; |
357 | } | 357 | } |
358 | } | 358 | } |
359 | 359 | ||
360 | // Load the texture coordinates. | 360 | // Load the texture coordinates. |
361 | float sw = (float) header->skinWidth; | 361 | float sw = (float) header->skinWidth; |
362 | float sh = (float) header->skinHeight; | 362 | float sh = (float) header->skinHeight; |
363 | texCoord_t* texc = (texCoord_t*) &buffer[header->offsetTexCoords]; | 363 | texCoord_t* texc = (texCoord_t*) &buffer[header->offsetTexCoords]; |
364 | for (i = 0; i < header->numTexCoords; ++i) | 364 | for (i = 0; i < header->numTexCoords; ++i) |
365 | { | 365 | { |
366 | texCoords[i].s = (float)texc->s / sw; | 366 | texCoords[i].s = (float)texc->s / sw; |
367 | texCoords[i].t = 1.0f - (float)texc->t / sh; | 367 | texCoords[i].t = 1.0f - (float)texc->t / sh; |
368 | texc++; | 368 | texc++; |
369 | } | 369 | } |
370 | 370 | ||
371 | // Iterate over every frame and compute normals for every triangle. | 371 | // Iterate over every frame and compute normals for every triangle. |
372 | vec3 n; | 372 | vec3 n; |
373 | 373 | ||
374 | normal_map map; | 374 | normal_map map; |
375 | normal_map_initialise (&map, header->numVertices); | 375 | normal_map_initialise (&map, header->numVertices); |
376 | 376 | ||
377 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) | 377 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) |
378 | { | 378 | { |
379 | // Set a pointer to the triangle array. | 379 | // Set a pointer to the triangle array. |
380 | triangle* t = triangles; | 380 | triangle* t = triangles; |
381 | 381 | ||
382 | // Set a pointer to the vertex array at the appropiate position. | 382 | // Set a pointer to the vertex array at the appropiate position. |
383 | vec3* vertex_array = vertices + header->numVertices * currentFrame; | 383 | vec3* vertex_array = vertices + header->numVertices * currentFrame; |
384 | 384 | ||
385 | // Set a pointer to the normals array at the appropiate position. | 385 | // Set a pointer to the normals array at the appropiate position. |
386 | vec3* normals_ptr = normals + header->numVertices * currentFrame; | 386 | vec3* normals_ptr = normals + header->numVertices * currentFrame; |
387 | 387 | ||
388 | normal_map_clear (&map, normals_ptr, vertex_array); | 388 | normal_map_clear (&map, normals_ptr, vertex_array); |
389 | 389 | ||
390 | for (i = 0; i < header->numTriangles; ++i) | 390 | for (i = 0; i < header->numTriangles; ++i) |
391 | { | 391 | { |
392 | // Compute face normal. | 392 | // Compute face normal. |
393 | vec3* v0 = &vertex_array[t->vertexIndices[0]]; | 393 | vec3* v0 = &vertex_array[t->vertexIndices[0]]; |
394 | vec3* v1 = &vertex_array[t->vertexIndices[1]]; | 394 | vec3* v1 = &vertex_array[t->vertexIndices[1]]; |
395 | vec3* v2 = &vertex_array[t->vertexIndices[2]]; | 395 | vec3* v2 = &vertex_array[t->vertexIndices[2]]; |
396 | normal (clockwise, v0, v1, v2, &n); | 396 | normal (clockwise, v0, v1, v2, &n); |
397 | 397 | ||
398 | // Add face normal to each of the face's vertices. | 398 | // Add face normal to each of the face's vertices. |
399 | normal_map_insert (&map, v0, n); | 399 | normal_map_insert (&map, v0, n); |
400 | normal_map_insert (&map, v1, n); | 400 | normal_map_insert (&map, v1, n); |
401 | normal_map_insert (&map, v2, n); | 401 | normal_map_insert (&map, v2, n); |
402 | 402 | ||
403 | t++; | 403 | t++; |
404 | } | 404 | } |
405 | 405 | ||
406 | compute_normals (&map, left_handed); | 406 | compute_normals (&map, left_handed); |
407 | } | 407 | } |
408 | 408 | ||
409 | // Load the model's skins. | 409 | // Load the model's skins. |
410 | const skin* s = (const skin*) &buffer[header->offsetSkins]; | 410 | const skin* s = (const skin*) &buffer[header->offsetSkins]; |
411 | for (i = 0; i < header->numSkins; ++i) | 411 | for (i = 0; i < header->numSkins; ++i) |
412 | { | 412 | { |
413 | memcpy (skins[i].name, s->name, 64); | 413 | memcpy (skins[i].name, s->name, 64); |
414 | s++; | 414 | s++; |
415 | } | 415 | } |
416 | 416 | ||
417 | // Load the model's animations. | 417 | // Load the model's animations. |
418 | unsigned start = 0; | 418 | unsigned start = 0; |
419 | name = 0; | 419 | name = 0; |
420 | animation* currentAnimation = animations; | 420 | animation* currentAnimation = animations; |
421 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) | 421 | for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) |
422 | { | 422 | { |
423 | frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; | 423 | frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; |
424 | if (name == 0) | 424 | if (name == 0) |
425 | { | 425 | { |
426 | name = frame->name; | 426 | name = frame->name; |
427 | } | 427 | } |
428 | else if (!frame_equal(name, frame->name)) | 428 | else if (!frame_equal(name, frame->name)) |
429 | { | 429 | { |
430 | memcpy (currentAnimation->name, name, 16); | 430 | memcpy (currentAnimation->name, name, 16); |
431 | animation_remove_numbers (currentAnimation->name); | 431 | animation_remove_numbers (currentAnimation->name); |
432 | currentAnimation->start = start; | 432 | currentAnimation->start = start; |
433 | currentAnimation->end = currentFrame-1; | 433 | currentAnimation->end = currentFrame-1; |
434 | if (currentAnimation != animations) | 434 | if (currentAnimation != animations) |
435 | { | 435 | { |
436 | animation* prev = currentAnimation; | 436 | animation* prev = currentAnimation; |
437 | prev--; | 437 | prev--; |
438 | prev->end = start-1; | 438 | prev->end = start-1; |
439 | } | 439 | } |
440 | name = frame->name; | 440 | name = frame->name; |
441 | currentAnimation++; | 441 | currentAnimation++; |
442 | start = currentFrame; | 442 | start = currentFrame; |
443 | } | 443 | } |
444 | } | 444 | } |
445 | currentAnimation = animations + numAnimations - 1; | 445 | currentAnimation = animations + numAnimations - 1; |
446 | memcpy (currentAnimation->name, name, 16); | 446 | memcpy (currentAnimation->name, name, 16); |
447 | animation_remove_numbers (currentAnimation->name); | 447 | animation_remove_numbers (currentAnimation->name); |
448 | currentAnimation->start = start; | 448 | currentAnimation->start = start; |
449 | currentAnimation->end = header->numFrames-1; | 449 | currentAnimation->end = header->numFrames-1; |
450 | 450 | ||
451 | /*printf ("finished loading model %s\n", filename); | 451 | /*printf ("finished loading model %s\n", filename); |
452 | printf ("numAnimations: %u\n", numAnimations); | 452 | printf ("numAnimations: %u\n", numAnimations); |
453 | printf ("animations: %p\n", animations); | 453 | printf ("animations: %p\n", animations); |
454 | 454 | ||
455 | currentAnimation = animations; | 455 | currentAnimation = animations; |
456 | for (i = 0; i < numAnimations; ++i) | 456 | for (i = 0; i < numAnimations; ++i) |
457 | { | 457 | { |
458 | printf ("Animation %d, name: %s, start: %d, end %d\n", | 458 | printf ("Animation %d, name: %s, start: %d, end %d\n", |
459 | i, currentAnimation->name, currentAnimation->start, currentAnimation->end); | 459 | i, currentAnimation->name, currentAnimation->start, currentAnimation->end); |
460 | currentAnimation++; | 460 | currentAnimation++; |
461 | }*/ | 461 | }*/ |
462 | 462 | ||
463 | model->vertices = vertices; | 463 | model->vertices = vertices; |
464 | model->normals = normals; | 464 | model->normals = normals; |
465 | model->texCoords = texCoords; | 465 | model->texCoords = texCoords; |
466 | model->triangles = triangles; | 466 | model->triangles = triangles; |
467 | model->skins = skins; | 467 | model->skins = skins; |
468 | model->animations = animations; | 468 | model->animations = animations; |
469 | 469 | ||
470 | model->numFrames = header->numFrames; | 470 | model->numFrames = header->numFrames; |
471 | model->numVertices = header->numVertices; | 471 | model->numVertices = header->numVertices; |
472 | model->numTriangles = header->numTriangles; | 472 | model->numTriangles = header->numTriangles; |
473 | model->numTexCoords = header->numTexCoords; | 473 | model->numTexCoords = header->numTexCoords; |
474 | model->numSkins = header->numSkins; | 474 | model->numSkins = header->numSkins; |
475 | model->numAnimations = numAnimations; | 475 | model->numAnimations = numAnimations; |
476 | 476 | ||
477 | free(buffer); | 477 | free(buffer); |
478 | 478 | ||
479 | return Model_Success; | 479 | return Model_Success; |
480 | } | 480 | } |
diff --git a/Spear/Assets/Model/Model.c b/Spear/Assets/Model/Model.c index 00bcf30..fd588ec 100644 --- a/Spear/Assets/Model/Model.c +++ b/Spear/Assets/Model/Model.c | |||
@@ -1,112 +1,112 @@ | |||
1 | #include "Model.h" | 1 | #include "Model.h" |
2 | #include <stdlib.h> // free | 2 | #include <stdlib.h> // free |
3 | #include <math.h> | 3 | #include <math.h> |
4 | 4 | ||
5 | 5 | ||
6 | #define TO_RAD M_PI / 180.0 | 6 | #define TO_RAD M_PI / 180.0 |
7 | 7 | ||
8 | 8 | ||
9 | static void safe_free (void* ptr) | 9 | static void safe_free (void* ptr) |
10 | { | 10 | { |
11 | if (ptr) | 11 | if (ptr) |
12 | { | 12 | { |
13 | free (ptr); | 13 | free (ptr); |
14 | ptr = 0; | 14 | ptr = 0; |
15 | } | 15 | } |
16 | } | 16 | } |
17 | 17 | ||
18 | 18 | ||
19 | void model_free (Model* model) | 19 | void model_free (Model* model) |
20 | { | 20 | { |
21 | safe_free (model->vertices); | 21 | safe_free (model->vertices); |
22 | safe_free (model->normals); | 22 | safe_free (model->normals); |
23 | safe_free (model->texCoords); | 23 | safe_free (model->texCoords); |
24 | safe_free (model->triangles); | 24 | safe_free (model->triangles); |
25 | safe_free (model->skins); | 25 | safe_free (model->skins); |
26 | safe_free (model->animations); | 26 | safe_free (model->animations); |
27 | } | 27 | } |
28 | 28 | ||
29 | 29 | ||
30 | void model_to_ground (Model* model) | 30 | void model_to_ground (Model* model) |
31 | { | 31 | { |
32 | unsigned i, f; | 32 | unsigned i, f; |
33 | vec3* v = model->vertices; | 33 | vec3* v = model->vertices; |
34 | 34 | ||
35 | // Compute the minimum y coordinate for each frame and translate | 35 | // Compute the minimum y coordinate for each frame and translate |
36 | // the model appropriately. | 36 | // the model appropriately. |
37 | for (f = 0; f < model->numFrames; ++f) | 37 | for (f = 0; f < model->numFrames; ++f) |
38 | { | 38 | { |
39 | vec3* w = v; | 39 | vec3* w = v; |
40 | float y = v->y; | 40 | float y = v->y; |
41 | 41 | ||
42 | for (i = 0; i < model->numVertices; ++i, ++v) | 42 | for (i = 0; i < model->numVertices; ++i, ++v) |
43 | { | 43 | { |
44 | y = fmin (y, v->y); | 44 | y = fmin (y, v->y); |
45 | } | 45 | } |
46 | 46 | ||
47 | v = w; | 47 | v = w; |
48 | for (i = 0; i < model->numVertices; ++i, ++v) | 48 | for (i = 0; i < model->numVertices; ++i, ++v) |
49 | { | 49 | { |
50 | v->y -= y; | 50 | v->y -= y; |
51 | } | 51 | } |
52 | } | 52 | } |
53 | } | 53 | } |
54 | 54 | ||
55 | 55 | ||
56 | void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris) | 56 | void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris) |
57 | { | 57 | { |
58 | int i; | 58 | int i; |
59 | int j = model->numVertices; | 59 | int j = model->numVertices; |
60 | 60 | ||
61 | vec3* v = model->vertices + j * frame; | 61 | vec3* v = model->vertices + j * frame; |
62 | vec3* n = model->normals + j * frame; | 62 | vec3* n = model->normals + j * frame; |
63 | texCoord* t = model->texCoords; | 63 | texCoord* t = model->texCoords; |
64 | triangle* tri = model->triangles; | 64 | triangle* tri = model->triangles; |
65 | 65 | ||
66 | 66 | ||
67 | for (i = 0; i < j; ++i, ++tri, ++tris) | 67 | for (i = 0; i < j; ++i, ++tri, ++tris) |
68 | { | 68 | { |
69 | tris->v0 = v[tri->vertexIndices[0]]; | 69 | tris->v0 = v[tri->vertexIndices[0]]; |
70 | tris->v1 = v[tri->vertexIndices[1]]; | 70 | tris->v1 = v[tri->vertexIndices[1]]; |
71 | tris->v2 = v[tri->vertexIndices[2]]; | 71 | tris->v2 = v[tri->vertexIndices[2]]; |
72 | 72 | ||
73 | tris->n0 = n[tri->vertexIndices[0]]; | 73 | tris->n0 = n[tri->vertexIndices[0]]; |
74 | tris->n1 = n[tri->vertexIndices[1]]; | 74 | tris->n1 = n[tri->vertexIndices[1]]; |
75 | tris->n2 = n[tri->vertexIndices[2]]; | 75 | tris->n2 = n[tri->vertexIndices[2]]; |
76 | 76 | ||
77 | tris->t0 = t[tri->textureIndices[0]]; | 77 | tris->t0 = t[tri->textureIndices[0]]; |
78 | tris->t1 = t[tri->textureIndices[1]]; | 78 | tris->t1 = t[tri->textureIndices[1]]; |
79 | tris->t2 = t[tri->textureIndices[2]]; | 79 | tris->t2 = t[tri->textureIndices[2]]; |
80 | } | 80 | } |
81 | } | 81 | } |
82 | 82 | ||
83 | 83 | ||
84 | void model_compute_boxes (Model* model, float* points) | 84 | void model_compute_boxes (Model* model, float* points) |
85 | { | 85 | { |
86 | vec3* v = model->vertices; | 86 | vec3* v = model->vertices; |
87 | 87 | ||
88 | unsigned f; | 88 | unsigned f; |
89 | for (f = 0; f < model->numFrames; ++f) | 89 | for (f = 0; f < model->numFrames; ++f) |
90 | { | 90 | { |
91 | float xmin = v->x; | 91 | float xmin = v->x; |
92 | float xmax = v->x; | 92 | float xmax = v->x; |
93 | float ymin = v->y; | 93 | float ymin = v->y; |
94 | float ymax = v->y; | 94 | float ymax = v->y; |
95 | float zmin = v->z; | 95 | float zmin = v->z; |
96 | float zmax = v->z; | 96 | float zmax = v->z; |
97 | 97 | ||
98 | unsigned i; | 98 | unsigned i; |
99 | for (i = 0; i < model->numVertices; ++i, ++v) | 99 | for (i = 0; i < model->numVertices; ++i, ++v) |
100 | { | 100 | { |
101 | xmin = fmin (xmin, v->x); | 101 | xmin = fmin (xmin, v->x); |
102 | ymin = fmin (ymin, v->y); | 102 | ymin = fmin (ymin, v->y); |
103 | zmin = fmin (zmin, v->z); | 103 | zmin = fmin (zmin, v->z); |
104 | xmax = fmax (xmax, v->x); | 104 | xmax = fmax (xmax, v->x); |
105 | ymax = fmax (ymax, v->y); | 105 | ymax = fmax (ymax, v->y); |
106 | zmax = fmax (zmax, v->z); | 106 | zmax = fmax (zmax, v->z); |
107 | } | 107 | } |
108 | 108 | ||
109 | *points++ = xmin; *points++ = ymin; *points++ = zmin; | 109 | *points++ = xmin; *points++ = ymin; *points++ = zmin; |
110 | *points++ = xmax; *points++ = ymax; *points++ = zmax; | 110 | *points++ = xmax; *points++ = ymax; *points++ = zmax; |
111 | } | 111 | } |
112 | } | 112 | } |
diff --git a/Spear/Assets/Model/Model.h b/Spear/Assets/Model/Model.h index eb9c39b..0f2aece 100644 --- a/Spear/Assets/Model/Model.h +++ b/Spear/Assets/Model/Model.h | |||
@@ -1,100 +1,100 @@ | |||
1 | #ifndef _SPEAR_MODEL_H | 1 | #ifndef _SPEAR_MODEL_H |
2 | #define _SPEAR_MODEL_H | 2 | #define _SPEAR_MODEL_H |
3 | 3 | ||
4 | #include "sys_types.h" | 4 | #include "sys_types.h" |
5 | 5 | ||
6 | 6 | ||
7 | typedef struct | 7 | typedef struct |
8 | { | 8 | { |
9 | char name[64]; | 9 | char name[64]; |
10 | } | 10 | } |
11 | skin; | 11 | skin; |
12 | 12 | ||
13 | 13 | ||
14 | typedef struct | 14 | typedef struct |
15 | { | 15 | { |
16 | float x, y, z; | 16 | float x, y, z; |
17 | } | 17 | } |
18 | vec3; | 18 | vec3; |
19 | 19 | ||
20 | 20 | ||
21 | typedef struct | 21 | typedef struct |
22 | { | 22 | { |
23 | float s, t; | 23 | float s, t; |
24 | } | 24 | } |
25 | texCoord; | 25 | texCoord; |
26 | 26 | ||
27 | 27 | ||
28 | typedef struct | 28 | typedef struct |
29 | { | 29 | { |
30 | U16 vertexIndices[3]; | 30 | U16 vertexIndices[3]; |
31 | U16 textureIndices[3]; | 31 | U16 textureIndices[3]; |
32 | } | 32 | } |
33 | triangle; | 33 | triangle; |
34 | 34 | ||
35 | 35 | ||
36 | typedef struct | 36 | typedef struct |
37 | { | 37 | { |
38 | char name[16]; | 38 | char name[16]; |
39 | unsigned int start; | 39 | unsigned int start; |
40 | unsigned int end; | 40 | unsigned int end; |
41 | } | 41 | } |
42 | animation; | 42 | animation; |
43 | 43 | ||
44 | 44 | ||
45 | typedef struct | 45 | typedef struct |
46 | { | 46 | { |
47 | vec3* vertices; // One array per frame. | 47 | vec3* vertices; // One array per frame. |
48 | vec3* normals; // One array per frame. One normal per vertex per frame. | 48 | vec3* normals; // One array per frame. One normal per vertex per frame. |
49 | texCoord* texCoords; // One array for all frames. | 49 | texCoord* texCoords; // One array for all frames. |
50 | triangle* triangles; // One array for all frames. | 50 | triangle* triangles; // One array for all frames. |
51 | skin* skins; // Holds the model's texture files. | 51 | skin* skins; // Holds the model's texture files. |
52 | animation* animations; // Holds the model's animations. | 52 | animation* animations; // Holds the model's animations. |
53 | 53 | ||
54 | unsigned int numFrames; | 54 | unsigned int numFrames; |
55 | unsigned int numVertices; // Number of vertices per frame. | 55 | unsigned int numVertices; // Number of vertices per frame. |
56 | unsigned int numTriangles; // Number of triangles in one frame. | 56 | unsigned int numTriangles; // Number of triangles in one frame. |
57 | unsigned int numTexCoords; // Number of texture coordinates in one frame. | 57 | unsigned int numTexCoords; // Number of texture coordinates in one frame. |
58 | unsigned int numSkins; | 58 | unsigned int numSkins; |
59 | unsigned int numAnimations; | 59 | unsigned int numAnimations; |
60 | } | 60 | } |
61 | Model; | 61 | Model; |
62 | 62 | ||
63 | 63 | ||
64 | typedef struct | 64 | typedef struct |
65 | { | 65 | { |
66 | vec3 v0; | 66 | vec3 v0; |
67 | vec3 v1; | 67 | vec3 v1; |
68 | vec3 v2; | 68 | vec3 v2; |
69 | vec3 n0; | 69 | vec3 n0; |
70 | vec3 n1; | 70 | vec3 n1; |
71 | vec3 n2; | 71 | vec3 n2; |
72 | texCoord t0; | 72 | texCoord t0; |
73 | texCoord t1; | 73 | texCoord t1; |
74 | texCoord t2; | 74 | texCoord t2; |
75 | } | 75 | } |
76 | model_triangle; | 76 | model_triangle; |
77 | 77 | ||
78 | 78 | ||
79 | #ifdef __cplusplus | 79 | #ifdef __cplusplus |
80 | extern "C" { | 80 | extern "C" { |
81 | #endif | 81 | #endif |
82 | 82 | ||
83 | /// Frees the given Model from memory. | 83 | /// Frees the given Model from memory. |
84 | /// The 'model' pointer itself is not freed. | 84 | /// The 'model' pointer itself is not freed. |
85 | void model_free (Model* model); | 85 | void model_free (Model* model); |
86 | 86 | ||
87 | /// Translate the Model such that its lowest point has y = 0. | 87 | /// Translate the Model such that its lowest point has y = 0. |
88 | void model_to_ground (Model* model); | 88 | void model_to_ground (Model* model); |
89 | 89 | ||
90 | /// Copy the triangles of the given frame from the Model into the given array. | 90 | /// Copy the triangles of the given frame from the Model into the given array. |
91 | void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris); | 91 | void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris); |
92 | 92 | ||
93 | /// Compute the model's 2d AABBs. | 93 | /// Compute the model's 2d AABBs. |
94 | void model_compute_boxes (Model* model, float* points); | 94 | void model_compute_boxes (Model* model, float* points); |
95 | 95 | ||
96 | #ifdef __cplusplus | 96 | #ifdef __cplusplus |
97 | } | 97 | } |
98 | #endif | 98 | #endif |
99 | 99 | ||
100 | #endif // _SPEAR_MODEL_H | 100 | #endif // _SPEAR_MODEL_H |
diff --git a/Spear/Assets/Model/Model_error_code.h b/Spear/Assets/Model/Model_error_code.h index a94a31b..d306052 100644 --- a/Spear/Assets/Model/Model_error_code.h +++ b/Spear/Assets/Model/Model_error_code.h | |||
@@ -1,16 +1,16 @@ | |||
1 | #ifndef _SPEAR_MODEL_ERROR_CODE_H | 1 | #ifndef _SPEAR_MODEL_ERROR_CODE_H |
2 | #define _SPEAR_MODEL_ERROR_CODE_H | 2 | #define _SPEAR_MODEL_ERROR_CODE_H |
3 | 3 | ||
4 | typedef enum | 4 | typedef enum |
5 | { | 5 | { |
6 | Model_Success, | 6 | Model_Success, |
7 | Model_Read_Error, | 7 | Model_Read_Error, |
8 | Model_Memory_Allocation_Error, | 8 | Model_Memory_Allocation_Error, |
9 | Model_File_Not_Found, | 9 | Model_File_Not_Found, |
10 | Model_File_Mismatch, | 10 | Model_File_Mismatch, |
11 | Model_No_Suitable_Loader, | 11 | Model_No_Suitable_Loader, |
12 | } | 12 | } |
13 | Model_error_code; | 13 | Model_error_code; |
14 | 14 | ||
15 | #endif // _SPEAR_MODEL_ERROR_CODE_H | 15 | #endif // _SPEAR_MODEL_ERROR_CODE_H |
16 | 16 | ||
diff --git a/Spear/Assets/Model/OBJ/Makefile b/Spear/Assets/Model/OBJ/Makefile index 34424f7..9630c9d 100644 --- a/Spear/Assets/Model/OBJ/Makefile +++ b/Spear/Assets/Model/OBJ/Makefile | |||
@@ -1,15 +1,15 @@ | |||
1 | test: ../Model.o OBJ_load.o cvector.o test.o | 1 | test: ../Model.o OBJ_load.o cvector.o test.o |
2 | $(CC) Model.o OBJ_load.o cvector.o test.o -o $@ -lm | 2 | $(CC) Model.o OBJ_load.o cvector.o test.o -o $@ -lm |
3 | 3 | ||
4 | vector: cvector.o vector-test.o | 4 | vector: cvector.o vector-test.o |
5 | $(CC) cvector.o vector-test.o -o vector | 5 | $(CC) cvector.o vector-test.o -o vector |
6 | 6 | ||
7 | 7 | ||
8 | %.o: %.c %.h | 8 | %.o: %.c %.h |
9 | $(CC) -g -c $< | 9 | $(CC) -g -c $< |
10 | 10 | ||
11 | 11 | ||
12 | clean: | 12 | clean: |
13 | @rm -f test vector | 13 | @rm -f test vector |
14 | @rm -f *.o | 14 | @rm -f *.o |
15 | 15 | ||
diff --git a/Spear/Assets/Model/OBJ/OBJ_load.c b/Spear/Assets/Model/OBJ/OBJ_load.c index 594ea0f..cdd39c9 100644 --- a/Spear/Assets/Model/OBJ/OBJ_load.c +++ b/Spear/Assets/Model/OBJ/OBJ_load.c | |||
@@ -1,274 +1,274 @@ | |||
1 | #include "OBJ_load.h" | 1 | #include "OBJ_load.h" |
2 | #include "cvector.h" | 2 | #include "cvector.h" |
3 | #include <stdio.h> | 3 | #include <stdio.h> |
4 | #include <stdlib.h> // free | 4 | #include <stdlib.h> // free |
5 | #include <string.h> // memcpy | 5 | #include <string.h> // memcpy |
6 | #include <math.h> // sqrt | 6 | #include <math.h> // sqrt |
7 | 7 | ||
8 | 8 | ||
9 | char lastError [128]; | 9 | char lastError [128]; |
10 | 10 | ||
11 | 11 | ||
12 | static void safe_free (void* ptr) | 12 | static void safe_free (void* ptr) |
13 | { | 13 | { |
14 | if (ptr) | 14 | if (ptr) |
15 | { | 15 | { |
16 | free (ptr); | 16 | free (ptr); |
17 | ptr = 0; | 17 | ptr = 0; |
18 | } | 18 | } |
19 | } | 19 | } |
20 | 20 | ||
21 | 21 | ||
22 | static void cross (vec3 a, vec3 b, vec3* c) | 22 | static void cross (vec3 a, vec3 b, vec3* c) |
23 | { | 23 | { |
24 | c->x = a.y * b.z - a.z * b.y; | 24 | c->x = a.y * b.z - a.z * b.y; |
25 | c->y = a.z * b.x - a.x * b.z; | 25 | c->y = a.z * b.x - a.x * b.z; |
26 | c->z = a.x * b.y - a.y * b.x; | 26 | c->z = a.x * b.y - a.y * b.x; |
27 | } | 27 | } |
28 | 28 | ||
29 | 29 | ||
30 | static void vec3_sub (vec3 a, vec3 b, vec3* out) | 30 | static void vec3_sub (vec3 a, vec3 b, vec3* out) |
31 | { | 31 | { |
32 | out->x = a.x - b.x; | 32 | out->x = a.x - b.x; |
33 | out->y = a.y - b.y; | 33 | out->y = a.y - b.y; |
34 | out->z = a.z - b.z; | 34 | out->z = a.z - b.z; |
35 | } | 35 | } |
36 | 36 | ||
37 | 37 | ||
38 | static void compute_normal (char clockwise, vec3 p1, vec3 p2, vec3 p3, vec3* n) | 38 | static void compute_normal (char clockwise, vec3 p1, vec3 p2, vec3 p3, vec3* n) |
39 | { | 39 | { |
40 | vec3 v1, v2; | 40 | vec3 v1, v2; |
41 | if (!clockwise) | 41 | if (!clockwise) |
42 | { | 42 | { |
43 | vec3_sub (p3, p2, &v1); | 43 | vec3_sub (p3, p2, &v1); |
44 | vec3_sub (p1, p2, &v2); | 44 | vec3_sub (p1, p2, &v2); |
45 | } | 45 | } |
46 | else | 46 | else |
47 | { | 47 | { |
48 | vec3_sub (p1, p2, &v1); | 48 | vec3_sub (p1, p2, &v1); |
49 | vec3_sub (p3, p2, &v2); | 49 | vec3_sub (p3, p2, &v2); |
50 | } | 50 | } |
51 | cross (v1, v2, n); | 51 | cross (v1, v2, n); |
52 | } | 52 | } |
53 | 53 | ||
54 | 54 | ||
55 | static void normalise (vec3* v) | 55 | static void normalise (vec3* v) |
56 | { | 56 | { |
57 | float x = v->x; | 57 | float x = v->x; |
58 | float y = v->y; | 58 | float y = v->y; |
59 | float z = v->z; | 59 | float z = v->z; |
60 | float mag = sqrt (x*x + y*y + z*z); | 60 | float mag = sqrt (x*x + y*y + z*z); |
61 | mag = mag == 0.0f ? 1.0f : mag; | 61 | mag = mag == 0.0f ? 1.0f : mag; |
62 | v->x /= mag; | 62 | v->x /= mag; |
63 | v->y /= mag; | 63 | v->y /= mag; |
64 | v->z /= mag; | 64 | v->z /= mag; |
65 | } | 65 | } |
66 | 66 | ||
67 | 67 | ||
68 | static void vec3_add (vec3 a, vec3* b) | 68 | static void vec3_add (vec3 a, vec3* b) |
69 | { | 69 | { |
70 | b->x += a.x; | 70 | b->x += a.x; |
71 | b->y += a.y; | 71 | b->y += a.y; |
72 | b->z += a.z; | 72 | b->z += a.z; |
73 | } | 73 | } |
74 | 74 | ||
75 | 75 | ||
76 | static void read_vertex (FILE* file, vec3* vert) | 76 | static void read_vertex (FILE* file, vec3* vert) |
77 | { | 77 | { |
78 | fscanf (file, "%f %f", &vert->x, &vert->y); | 78 | fscanf (file, "%f %f", &vert->x, &vert->y); |
79 | if (fscanf(file, "%f", &vert->z) == 0) vert->z = 0.0f; | 79 | if (fscanf(file, "%f", &vert->z) == 0) vert->z = 0.0f; |
80 | } | 80 | } |
81 | 81 | ||
82 | 82 | ||
83 | static void read_normal (FILE* file, vec3* normal) | 83 | static void read_normal (FILE* file, vec3* normal) |
84 | { | 84 | { |
85 | fscanf (file, "%f %f %f", &normal->x, &normal->y, &normal->z); | 85 | fscanf (file, "%f %f %f", &normal->x, &normal->y, &normal->z); |
86 | } | 86 | } |
87 | 87 | ||
88 | 88 | ||
89 | static void read_tex_coord (FILE* file, texCoord* texc) | 89 | static void read_tex_coord (FILE* file, texCoord* texc) |
90 | { | 90 | { |
91 | fscanf (file, "%f %f", &texc->s, &texc->t); | 91 | fscanf (file, "%f %f", &texc->s, &texc->t); |
92 | } | 92 | } |
93 | 93 | ||
94 | 94 | ||
95 | static void read_face (FILE* file, | 95 | static void read_face (FILE* file, |
96 | char clockwise, | 96 | char clockwise, |
97 | vector* vertices, | 97 | vector* vertices, |
98 | vector* normals, | 98 | vector* normals, |
99 | vector* triangles) | 99 | vector* triangles) |
100 | { | 100 | { |
101 | vector idxs; | 101 | vector idxs; |
102 | vector texCoords; | 102 | vector texCoords; |
103 | 103 | ||
104 | vector_new (&idxs, sizeof(int), 4); | 104 | vector_new (&idxs, sizeof(int), 4); |
105 | vector_new (&texCoords, sizeof(int), 4); | 105 | vector_new (&texCoords, sizeof(int), 4); |
106 | 106 | ||
107 | unsigned int index; | 107 | unsigned int index; |
108 | unsigned int normal; | 108 | unsigned int normal; |
109 | unsigned int texc; | 109 | unsigned int texc; |
110 | 110 | ||
111 | fscanf (file, "f"); | 111 | fscanf (file, "f"); |
112 | 112 | ||
113 | while (!feof(file) && fscanf(file, "%d", &index) > 0) | 113 | while (!feof(file) && fscanf(file, "%d", &index) > 0) |
114 | { | 114 | { |
115 | vector_append (&idxs, &index); | 115 | vector_append (&idxs, &index); |
116 | 116 | ||
117 | if (fgetc (file) == '/') | 117 | if (fgetc (file) == '/') |
118 | { | 118 | { |
119 | fscanf (file, "%d", &texc); | 119 | fscanf (file, "%d", &texc); |
120 | vector_append (&texCoords, &texc); | 120 | vector_append (&texCoords, &texc); |
121 | } | 121 | } |
122 | else fseek (file, -1, SEEK_CUR); | 122 | else fseek (file, -1, SEEK_CUR); |
123 | 123 | ||
124 | if (fgetc (file) == '/') | 124 | if (fgetc (file) == '/') |
125 | { | 125 | { |
126 | fscanf (file, "%d", &normal); | 126 | fscanf (file, "%d", &normal); |
127 | } | 127 | } |
128 | else fseek (file, -1, SEEK_CUR); | 128 | else fseek (file, -1, SEEK_CUR); |
129 | } | 129 | } |
130 | 130 | ||
131 | // Triangulate the face and add its triangles to the triangles vector. | 131 | // Triangulate the face and add its triangles to the triangles vector. |
132 | triangle tri; | 132 | triangle tri; |
133 | tri.vertexIndices[0] = *((int*) vector_ith (&idxs, 0)) - 1; | 133 | tri.vertexIndices[0] = *((int*) vector_ith (&idxs, 0)) - 1; |
134 | tri.textureIndices[0] = *((int*) vector_ith (&texCoords, 0)) - 1; | 134 | tri.textureIndices[0] = *((int*) vector_ith (&texCoords, 0)) - 1; |
135 | 135 | ||
136 | int i; | 136 | int i; |
137 | for (i = 1; i < vector_size(&idxs)-1; i++) | 137 | for (i = 1; i < vector_size(&idxs)-1; i++) |
138 | { | 138 | { |
139 | tri.vertexIndices[1] = *((int*) vector_ith (&idxs, i)) - 1; | 139 | tri.vertexIndices[1] = *((int*) vector_ith (&idxs, i)) - 1; |
140 | tri.textureIndices[1] = *((int*) vector_ith (&texCoords, i)) - 1; | 140 | tri.textureIndices[1] = *((int*) vector_ith (&texCoords, i)) - 1; |
141 | tri.vertexIndices[2] = *((int*) vector_ith (&idxs, i+1)) - 1; | 141 | tri.vertexIndices[2] = *((int*) vector_ith (&idxs, i+1)) - 1; |
142 | tri.textureIndices[2] = *((int*) vector_ith (&texCoords, i+1)) - 1; | 142 | tri.textureIndices[2] = *((int*) vector_ith (&texCoords, i+1)) - 1; |
143 | vector_append (triangles, &tri); | 143 | vector_append (triangles, &tri); |
144 | } | 144 | } |
145 | 145 | ||
146 | // Compute face normal and add contribution to each of the face's vertices. | 146 | // Compute face normal and add contribution to each of the face's vertices. |
147 | unsigned int i0 = tri.vertexIndices[0]; | 147 | unsigned int i0 = tri.vertexIndices[0]; |
148 | unsigned int i1 = tri.vertexIndices[1]; | 148 | unsigned int i1 = tri.vertexIndices[1]; |
149 | unsigned int i2 = tri.vertexIndices[2]; | 149 | unsigned int i2 = tri.vertexIndices[2]; |
150 | 150 | ||
151 | vec3 n; | 151 | vec3 n; |
152 | vec3 v0 = *((vec3*) vector_ith (vertices, i0)); | 152 | vec3 v0 = *((vec3*) vector_ith (vertices, i0)); |
153 | vec3 v1 = *((vec3*) vector_ith (vertices, i1)); | 153 | vec3 v1 = *((vec3*) vector_ith (vertices, i1)); |
154 | vec3 v2 = *((vec3*) vector_ith (vertices, i2)); | 154 | vec3 v2 = *((vec3*) vector_ith (vertices, i2)); |
155 | compute_normal (clockwise, v0, v1, v2, &n); | 155 | compute_normal (clockwise, v0, v1, v2, &n); |
156 | 156 | ||
157 | for (i = 0; i < vector_size (&idxs); i++) | 157 | for (i = 0; i < vector_size (&idxs); i++) |
158 | { | 158 | { |
159 | int j = *((int*) vector_ith (&idxs, i)) - 1; | 159 | int j = *((int*) vector_ith (&idxs, i)) - 1; |
160 | vec3* normal = (vec3*) vector_ith (normals, j); | 160 | vec3* normal = (vec3*) vector_ith (normals, j); |
161 | vec3_add (n, normal); | 161 | vec3_add (n, normal); |
162 | } | 162 | } |
163 | 163 | ||
164 | vector_free (&idxs); | 164 | vector_free (&idxs); |
165 | vector_free (&texCoords); | 165 | vector_free (&texCoords); |
166 | } | 166 | } |
167 | 167 | ||
168 | 168 | ||
169 | Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model) | 169 | Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model) |
170 | { | 170 | { |
171 | vec3* norms = 0; | 171 | vec3* norms = 0; |
172 | vec3* verts = 0; | 172 | vec3* verts = 0; |
173 | texCoord* texcs = 0; | 173 | texCoord* texcs = 0; |
174 | triangle* tris = 0; | 174 | triangle* tris = 0; |
175 | 175 | ||
176 | FILE* file = fopen (filename, "r"); | 176 | FILE* file = fopen (filename, "r"); |
177 | if (file == NULL) return Model_File_Not_Found; | 177 | if (file == NULL) return Model_File_Not_Found; |
178 | 178 | ||
179 | vec3 vert; | 179 | vec3 vert; |
180 | vec3 normal; | 180 | vec3 normal; |
181 | texCoord texc; | 181 | texCoord texc; |
182 | 182 | ||
183 | vector vertices; | 183 | vector vertices; |
184 | vector normals; | 184 | vector normals; |
185 | vector texCoords; | 185 | vector texCoords; |
186 | vector triangles; | 186 | vector triangles; |
187 | 187 | ||
188 | int result = vector_new (&vertices, sizeof(vec3), 0) | 188 | int result = vector_new (&vertices, sizeof(vec3), 0) |
189 | | vector_new (&normals, sizeof(vec3), 0) | 189 | | vector_new (&normals, sizeof(vec3), 0) |
190 | | vector_new (&texCoords, sizeof(texCoord), 0) | 190 | | vector_new (&texCoords, sizeof(texCoord), 0) |
191 | | vector_new (&triangles, sizeof(triangle), 0); | 191 | | vector_new (&triangles, sizeof(triangle), 0); |
192 | 192 | ||
193 | if (result != 0) | 193 | if (result != 0) |
194 | { | 194 | { |
195 | safe_free (vertices.data); | 195 | safe_free (vertices.data); |
196 | safe_free (normals.data); | 196 | safe_free (normals.data); |
197 | safe_free (texCoords.data); | 197 | safe_free (texCoords.data); |
198 | safe_free (triangles.data); | 198 | safe_free (triangles.data); |
199 | return Model_Memory_Allocation_Error; | 199 | return Model_Memory_Allocation_Error; |
200 | } | 200 | } |
201 | 201 | ||
202 | while (!feof(file)) | 202 | while (!feof(file)) |
203 | { | 203 | { |
204 | switch (fgetc(file)) | 204 | switch (fgetc(file)) |
205 | { | 205 | { |
206 | case 'v': | 206 | case 'v': |
207 | switch (fgetc(file)) | 207 | switch (fgetc(file)) |
208 | { | 208 | { |
209 | case 't': | 209 | case 't': |
210 | read_tex_coord (file, &texc); | 210 | read_tex_coord (file, &texc); |
211 | vector_append (&texCoords, &texc); | 211 | vector_append (&texCoords, &texc); |
212 | break; | 212 | break; |
213 | 213 | ||
214 | case 'n': | 214 | case 'n': |
215 | read_normal (file, &normal); | 215 | read_normal (file, &normal); |
216 | vector_append (&normals, &normal); | 216 | vector_append (&normals, &normal); |
217 | break; | 217 | break; |
218 | 218 | ||
219 | default: | 219 | default: |
220 | read_vertex (file, &vert); | 220 | read_vertex (file, &vert); |
221 | vector_append (&vertices, &vert); | 221 | vector_append (&vertices, &vert); |
222 | break; | 222 | break; |
223 | } | 223 | } |
224 | break; | 224 | break; |
225 | 225 | ||
226 | case 'f': | 226 | case 'f': |
227 | // Initialise the normals vector if it is empty. | 227 | // Initialise the normals vector if it is empty. |
228 | if (vector_size(&normals) == 0) | 228 | if (vector_size(&normals) == 0) |
229 | { | 229 | { |
230 | vec3 zero; | 230 | vec3 zero; |
231 | zero.x = 0.0f; zero.y = 0.0f; zero.z = 0.0f; | 231 | zero.x = 0.0f; zero.y = 0.0f; zero.z = 0.0f; |
232 | vector_new (&normals, sizeof(vec3), vector_size(&vertices)); | 232 | vector_new (&normals, sizeof(vec3), vector_size(&vertices)); |
233 | vector_initialise (&normals, &zero); | 233 | vector_initialise (&normals, &zero); |
234 | } | 234 | } |
235 | read_face (file, clockwise, &vertices, &normals, &triangles); | 235 | read_face (file, clockwise, &vertices, &normals, &triangles); |
236 | break; | 236 | break; |
237 | 237 | ||
238 | case '#': | 238 | case '#': |
239 | { | 239 | { |
240 | int x = 17; | 240 | int x = 17; |
241 | while (x != '\n' && x != EOF) x = fgetc(file); | 241 | while (x != '\n' && x != EOF) x = fgetc(file); |
242 | break; | 242 | break; |
243 | } | 243 | } |
244 | 244 | ||
245 | default: break; | 245 | default: break; |
246 | } | 246 | } |
247 | } | 247 | } |
248 | 248 | ||
249 | fclose (file); | 249 | fclose (file); |
250 | 250 | ||
251 | unsigned numVertices = vector_size (&vertices); | 251 | unsigned numVertices = vector_size (&vertices); |
252 | 252 | ||
253 | // Normalise normals. | 253 | // Normalise normals. |
254 | unsigned i; | 254 | unsigned i; |
255 | for (i = 0; i < numVertices; ++i) | 255 | for (i = 0; i < numVertices; ++i) |
256 | { | 256 | { |
257 | normalise (vector_ith (&normals, i)); | 257 | normalise (vector_ith (&normals, i)); |
258 | } | 258 | } |
259 | 259 | ||
260 | model->vertices = (vec3*) vertices.data; | 260 | model->vertices = (vec3*) vertices.data; |
261 | model->normals = (vec3*) normals.data; | 261 | model->normals = (vec3*) normals.data; |
262 | model->texCoords = (texCoord*) texCoords.data; | 262 | model->texCoords = (texCoord*) texCoords.data; |
263 | model->triangles = (triangle*) triangles.data; | 263 | model->triangles = (triangle*) triangles.data; |
264 | model->skins = 0; | 264 | model->skins = 0; |
265 | model->animations = 0; | 265 | model->animations = 0; |
266 | model->numFrames = 1; | 266 | model->numFrames = 1; |
267 | model->numVertices = numVertices; | 267 | model->numVertices = numVertices; |
268 | model->numTriangles = vector_size (&triangles); | 268 | model->numTriangles = vector_size (&triangles); |
269 | model->numTexCoords = vector_size (&texCoords); | 269 | model->numTexCoords = vector_size (&texCoords); |
270 | model->numSkins = 0; | 270 | model->numSkins = 0; |
271 | model->numAnimations = 0; | 271 | model->numAnimations = 0; |
272 | 272 | ||
273 | return Model_Success; | 273 | return Model_Success; |
274 | } | 274 | } |
diff --git a/Spear/Assets/Model/OBJ/OBJ_load.h b/Spear/Assets/Model/OBJ/OBJ_load.h index f1de6c7..485d3cc 100644 --- a/Spear/Assets/Model/OBJ/OBJ_load.h +++ b/Spear/Assets/Model/OBJ/OBJ_load.h | |||
@@ -1,25 +1,25 @@ | |||
1 | #ifndef _OBJ_LOAD_H | 1 | #ifndef _OBJ_LOAD_H |
2 | #define _OBJ_LOAD_H | 2 | #define _OBJ_LOAD_H |
3 | 3 | ||
4 | #include "../Model.h" | 4 | #include "../Model.h" |
5 | #include "../Model_error_code.h" | 5 | #include "../Model_error_code.h" |
6 | 6 | ||
7 | 7 | ||
8 | #ifdef __cplusplus | 8 | #ifdef __cplusplus |
9 | extern "C" { | 9 | extern "C" { |
10 | #endif | 10 | #endif |
11 | 11 | ||
12 | /// Loads the OBJ file specified by the given string. | 12 | /// Loads the OBJ file specified by the given string. |
13 | /// 'clockwise' should be 1 if you plan to render the model in a clockwise environment, 0 otherwise. | 13 | /// 'clockwise' should be 1 if you plan to render the model in a clockwise environment, 0 otherwise. |
14 | /// 'smooth_normals' should be 1 if you want the loader to compute smooth normals, 0 otherwise. | 14 | /// 'smooth_normals' should be 1 if you want the loader to compute smooth normals, 0 otherwise. |
15 | Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model); | 15 | Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model); |
16 | 16 | ||
17 | /// Gets the last error generated by the OBJ loader. | 17 | /// Gets the last error generated by the OBJ loader. |
18 | char* get_last_error (); | 18 | char* get_last_error (); |
19 | 19 | ||
20 | #ifdef __cplusplus | 20 | #ifdef __cplusplus |
21 | } | 21 | } |
22 | #endif | 22 | #endif |
23 | 23 | ||
24 | 24 | ||
25 | #endif // _OBJ_LOAD_H | 25 | #endif // _OBJ_LOAD_H |
diff --git a/Spear/Assets/Model/OBJ/cvector.c b/Spear/Assets/Model/OBJ/cvector.c index 4e90204..9213d8d 100644 --- a/Spear/Assets/Model/OBJ/cvector.c +++ b/Spear/Assets/Model/OBJ/cvector.c | |||
@@ -1,90 +1,90 @@ | |||
1 | #include "cvector.h" | 1 | #include "cvector.h" |
2 | #include <stdlib.h> // malloc, realloc, free | 2 | #include <stdlib.h> // malloc, realloc, free |
3 | #include <string.h> // memcpy | 3 | #include <string.h> // memcpy |
4 | 4 | ||
5 | 5 | ||
6 | int max (int a, int b) | 6 | int max (int a, int b) |
7 | { | 7 | { |
8 | if (a > b) return a; | 8 | if (a > b) return a; |
9 | return b; | 9 | return b; |
10 | } | 10 | } |
11 | 11 | ||
12 | 12 | ||
13 | int vector_new (vector* v, int elem_size, int num_elems) | 13 | int vector_new (vector* v, int elem_size, int num_elems) |
14 | { | 14 | { |
15 | int n = num_elems * elem_size; | 15 | int n = num_elems * elem_size; |
16 | 16 | ||
17 | char* data = 0; | 17 | char* data = 0; |
18 | if (num_elems > 0) | 18 | if (num_elems > 0) |
19 | { | 19 | { |
20 | data = (char*) malloc (n); | 20 | data = (char*) malloc (n); |
21 | if (data == NULL) return 1; | 21 | if (data == NULL) return 1; |
22 | } | 22 | } |
23 | 23 | ||
24 | v->data = data; | 24 | v->data = data; |
25 | v->next = data; | 25 | v->next = data; |
26 | v->chunk_size = n; | 26 | v->chunk_size = n; |
27 | v->elem_size = elem_size; | 27 | v->elem_size = elem_size; |
28 | 28 | ||
29 | return 0; | 29 | return 0; |
30 | } | 30 | } |
31 | 31 | ||
32 | 32 | ||
33 | void vector_free (vector* v) | 33 | void vector_free (vector* v) |
34 | { | 34 | { |
35 | if (v->data != 0) free (v->data); | 35 | if (v->data != 0) free (v->data); |
36 | } | 36 | } |
37 | 37 | ||
38 | 38 | ||
39 | void vector_initialise (vector* v, void* value) | 39 | void vector_initialise (vector* v, void* value) |
40 | { | 40 | { |
41 | char* ptr = v->data; | 41 | char* ptr = v->data; |
42 | int esize = v->elem_size; | 42 | int esize = v->elem_size; |
43 | int n = vector_size (v); | 43 | int n = vector_size (v); |
44 | 44 | ||
45 | int i; | 45 | int i; |
46 | for (i = 0; i < n; ++i) | 46 | for (i = 0; i < n; ++i) |
47 | { | 47 | { |
48 | memcpy (ptr, value, esize); | 48 | memcpy (ptr, value, esize); |
49 | ptr += esize; | 49 | ptr += esize; |
50 | } | 50 | } |
51 | } | 51 | } |
52 | 52 | ||
53 | 53 | ||
54 | int vector_append (vector* v, void* elem) | 54 | int vector_append (vector* v, void* elem) |
55 | { | 55 | { |
56 | // Realloc a bigger chunk when the vector runs out of space. | 56 | // Realloc a bigger chunk when the vector runs out of space. |
57 | if (v->next == v->data + v->chunk_size) | 57 | if (v->next == v->data + v->chunk_size) |
58 | { | 58 | { |
59 | int old_chunk_size = v->chunk_size; | 59 | int old_chunk_size = v->chunk_size; |
60 | int n = max (v->elem_size, 2 * old_chunk_size); | 60 | int n = max (v->elem_size, 2 * old_chunk_size); |
61 | 61 | ||
62 | char* data = (char*) realloc (v->data, n); | 62 | char* data = (char*) realloc (v->data, n); |
63 | if (data == NULL) return 1; | 63 | if (data == NULL) return 1; |
64 | 64 | ||
65 | v->data = data; | 65 | v->data = data; |
66 | v->next = data + old_chunk_size; | 66 | v->next = data + old_chunk_size; |
67 | v->chunk_size = n; | 67 | v->chunk_size = n; |
68 | } | 68 | } |
69 | 69 | ||
70 | memcpy ((void*)v->next, elem, v->elem_size); | 70 | memcpy ((void*)v->next, elem, v->elem_size); |
71 | v->next += v->elem_size; | 71 | v->next += v->elem_size; |
72 | } | 72 | } |
73 | 73 | ||
74 | 74 | ||
75 | void* vector_ith (vector* v, int i) | 75 | void* vector_ith (vector* v, int i) |
76 | { | 76 | { |
77 | return (void*) (v->data + i*v->elem_size); | 77 | return (void*) (v->data + i*v->elem_size); |
78 | } | 78 | } |
79 | 79 | ||
80 | 80 | ||
81 | int vector_size (vector* v) | 81 | int vector_size (vector* v) |
82 | { | 82 | { |
83 | return (v->next - v->data) / v->elem_size; | 83 | return (v->next - v->data) / v->elem_size; |
84 | } | 84 | } |
85 | 85 | ||
86 | 86 | ||
87 | int vector_capacity (vector* v) | 87 | int vector_capacity (vector* v) |
88 | { | 88 | { |
89 | return v->chunk_size / v->elem_size; | 89 | return v->chunk_size / v->elem_size; |
90 | } | 90 | } |
diff --git a/Spear/Assets/Model/OBJ/cvector.h b/Spear/Assets/Model/OBJ/cvector.h index 1d16c46..2c269e4 100644 --- a/Spear/Assets/Model/OBJ/cvector.h +++ b/Spear/Assets/Model/OBJ/cvector.h | |||
@@ -1,36 +1,36 @@ | |||
1 | #ifndef _C_SPEAR_VECTOR_H | 1 | #ifndef _C_SPEAR_VECTOR_H |
2 | #define _C_SPEAR_VECTOR_H | 2 | #define _C_SPEAR_VECTOR_H |
3 | 3 | ||
4 | typedef struct | 4 | typedef struct |
5 | { | 5 | { |
6 | char* data; | 6 | char* data; |
7 | char* next; | 7 | char* next; |
8 | int chunk_size; | 8 | int chunk_size; |
9 | int elem_size; | 9 | int elem_size; |
10 | } | 10 | } |
11 | vector; | 11 | vector; |
12 | 12 | ||
13 | /// Construct a new vector. | 13 | /// Construct a new vector. |
14 | /// Returns non-zero on error. | 14 | /// Returns non-zero on error. |
15 | int vector_new (vector* v, int elem_size, int num_elems); | 15 | int vector_new (vector* v, int elem_size, int num_elems); |
16 | 16 | ||
17 | /// Free the vector. | 17 | /// Free the vector. |
18 | void vector_free (vector* v); | 18 | void vector_free (vector* v); |
19 | 19 | ||
20 | /// Initialise every position to the given value. | 20 | /// Initialise every position to the given value. |
21 | void vector_initialise (vector* v, void* value); | 21 | void vector_initialise (vector* v, void* value); |
22 | 22 | ||
23 | /// Append an element. | 23 | /// Append an element. |
24 | /// Returns non-zero on error. | 24 | /// Returns non-zero on error. |
25 | int vector_append (vector* v, void* elem); | 25 | int vector_append (vector* v, void* elem); |
26 | 26 | ||
27 | /// Access the ith element. | 27 | /// Access the ith element. |
28 | void* vector_ith (vector* v, int i); | 28 | void* vector_ith (vector* v, int i); |
29 | 29 | ||
30 | /// Return the number of elements in the vector. | 30 | /// Return the number of elements in the vector. |
31 | int vector_size (vector* v); | 31 | int vector_size (vector* v); |
32 | 32 | ||
33 | /// Return the vector's capacity. | 33 | /// Return the vector's capacity. |
34 | int vector_capacity (vector* v); | 34 | int vector_capacity (vector* v); |
35 | 35 | ||
36 | #endif // _C_SPEAR_VECTOR_H | 36 | #endif // _C_SPEAR_VECTOR_H |
diff --git a/Spear/Assets/Model/sys_types.h b/Spear/Assets/Model/sys_types.h index e4eb251..6aca9e9 100644 --- a/Spear/Assets/Model/sys_types.h +++ b/Spear/Assets/Model/sys_types.h | |||
@@ -1,16 +1,16 @@ | |||
1 | #ifndef _SPEAR_SYS_TYPES_H | 1 | #ifndef _SPEAR_SYS_TYPES_H |
2 | #define _SPEAR_SYS_TYPES_H | 2 | #define _SPEAR_SYS_TYPES_H |
3 | 3 | ||
4 | #include <stdint.h> | 4 | #include <stdint.h> |
5 | 5 | ||
6 | typedef int8_t I8; | 6 | typedef int8_t I8; |
7 | typedef int16_t I16; | 7 | typedef int16_t I16; |
8 | typedef int32_t I32; | 8 | typedef int32_t I32; |
9 | typedef int64_t I64; | 9 | typedef int64_t I64; |
10 | typedef uint8_t U8; | 10 | typedef uint8_t U8; |
11 | typedef uint16_t U16; | 11 | typedef uint16_t U16; |
12 | typedef uint32_t U32; | 12 | typedef uint32_t U32; |
13 | typedef uint64_t U64; | 13 | typedef uint64_t U64; |
14 | 14 | ||
15 | #endif // _SPEAR_SYS_TYPES_H | 15 | #endif // _SPEAR_SYS_TYPES_H |
16 | 16 | ||
diff --git a/Spear/GL.hs b/Spear/GL.hs index b5b4dfb..f5cfe4e 100644 --- a/Spear/GL.hs +++ b/Spear/GL.hs | |||
@@ -1,720 +1,729 @@ | |||
1 | {-# LANGUAGE FlexibleInstances #-} | 1 | {-# LANGUAGE FlexibleInstances #-} |
2 | module Spear.GL | 2 | module Spear.GL |
3 | ( | 3 | ( |
4 | -- * Programs | 4 | -- * Programs |
5 | GLSLProgram | 5 | GLSLProgram |
6 | , newProgram | 6 | , newProgram |
7 | , linkProgram | 7 | , linkProgram |
8 | , useProgram | 8 | , useProgram |
9 | , unuseProgram | 9 | , unuseProgram |
10 | , withGLSLProgram | 10 | , withGLSLProgram |
11 | -- ** Locations | 11 | -- ** Locations |
12 | , attribLocation | 12 | , attribLocation |
13 | , fragLocation | 13 | , fragLocation |
14 | , uniformLocation | 14 | , uniformLocation |
15 | -- ** Uniforms | 15 | -- ** Uniforms |
16 | , Uniform(..) | 16 | , Uniform(..) |
17 | -- * Shaders | 17 | -- * Shaders |
18 | , GLSLShader | 18 | , GLSLShader |
19 | , ShaderType(..) | 19 | , ShaderType(..) |
20 | , attachShader | 20 | , attachShader |
21 | , detachShader | 21 | , detachShader |
22 | , loadShader | 22 | , loadShader |
23 | , newShader | 23 | , newShader |
24 | -- ** Source loading | 24 | -- ** Source loading |
25 | , loadSource | 25 | , loadSource |
26 | , shaderSource | 26 | , shaderSource |
27 | , readSource | 27 | , readSource |
28 | , compile | 28 | , compile |
29 | -- * Helper functions | 29 | -- * Helper functions |
30 | , ($=) | 30 | , ($=) |
31 | , Data.StateVar.get | 31 | , Data.StateVar.get |
32 | -- * VAOs | 32 | -- * VAOs |
33 | , VAO | 33 | , VAO |
34 | , newVAO | 34 | , newVAO |
35 | , bindVAO | 35 | , bindVAO |
36 | , unbindVAO | 36 | , unbindVAO |
37 | , enableVAOAttrib | 37 | , enableVAOAttrib |
38 | , attribVAOPointer | 38 | , attribVAOPointer |
39 | -- ** Rendering | 39 | -- ** Rendering |
40 | , drawArrays | 40 | , drawArrays |
41 | , drawElements | 41 | , drawElements |
42 | -- * Buffers | 42 | -- * Buffers |
43 | , GLBuffer | 43 | , GLBuffer |
44 | , TargetBuffer(..) | 44 | , TargetBuffer(..) |
45 | , BufferUsage(..) | 45 | , BufferUsage(..) |
46 | , newBuffer | 46 | , newBuffer |
47 | , bindBuffer | 47 | , bindBuffer |
48 | , unbindBuffer | 48 | , unbindBuffer |
49 | , BufferData(..) | 49 | , BufferData(..) |
50 | , bufferData' | 50 | , bufferData' |
51 | , withGLBuffer | 51 | , withGLBuffer |
52 | -- * Textures | 52 | -- * Textures |
53 | , Texture | 53 | , Texture |
54 | , SettableStateVar | 54 | , SettableStateVar |
55 | , ($) | 55 | , ($) |
56 | -- ** Creation and destruction | 56 | -- ** Creation and destruction |
57 | , newTexture | 57 | , newTexture |
58 | , loadTextureImage | 58 | , loadTextureImage |
59 | -- ** Manipulation | 59 | -- ** Manipulation |
60 | , bindTexture | 60 | , bindTexture |
61 | , unbindTexture | 61 | , unbindTexture |
62 | , loadTextureData | 62 | , loadTextureData |
63 | , texParami | 63 | , texParami |
64 | , texParamf | 64 | , texParamf |
65 | , activeTexture | 65 | , activeTexture |
66 | -- * Error Handling | 66 | -- * Error Handling |
67 | , getGLError | 67 | , getGLError |
68 | , printGLError | 68 | , printGLError |
69 | , assertGL | 69 | , assertGL |
70 | -- * OpenGL | 70 | -- * OpenGL |
71 | , module Graphics.Rendering.OpenGL.Raw.Core32 | 71 | , module Graphics.Rendering.OpenGL.Raw.Core32 |
72 | , Ptr | 72 | , Ptr |
73 | , nullPtr | 73 | , nullPtr |
74 | ) | 74 | ) |
75 | where | 75 | where |
76 | 76 | ||
77 | import Spear.Assets.Image | 77 | import Spear.Assets.Image |
78 | import Spear.Game | 78 | import Spear.Game |
79 | import Spear.Math.Matrix3 (Matrix3) | 79 | import Spear.Math.Matrix3 (Matrix3) |
80 | import Spear.Math.Matrix4 (Matrix4) | 80 | import Spear.Math.Matrix4 (Matrix4) |
81 | import Spear.Math.Vector | 81 | import Spear.Math.Vector |
82 | 82 | ||
83 | import Control.Monad | 83 | import Control.Monad |
84 | import Control.Monad.Trans.Class | 84 | import Control.Monad.Trans.Class |
85 | import Control.Monad.Trans.Error | 85 | import Control.Monad.Trans.Error |
86 | import Control.Monad.Trans.State as State | 86 | import Control.Monad.Trans.State as State |
87 | import qualified Data.ByteString.Char8 as B | 87 | import qualified Data.ByteString.Char8 as B |
88 | import Data.StateVar | 88 | import Data.StateVar |
89 | import Data.Word | 89 | import Data.Word |
90 | import Foreign.C.String | 90 | import Foreign.C.String |
91 | import Foreign.C.Types | 91 | import Foreign.C.Types |
92 | import Foreign.Ptr | 92 | import Foreign.Ptr |
93 | import Foreign.Storable | 93 | import Foreign.Storable |
94 | import Foreign.Marshal.Utils as Foreign (with) | 94 | import Foreign.Marshal.Utils as Foreign (with) |
95 | import Foreign.Marshal.Alloc (alloca) | 95 | import Foreign.Marshal.Alloc (alloca) |
96 | import Foreign.Marshal.Array (withArray) | 96 | import Foreign.Marshal.Array (withArray) |
97 | import Foreign.Storable (peek) | 97 | import Foreign.Storable (peek) |
98 | import Graphics.Rendering.OpenGL.Raw.Core32 | 98 | import Graphics.Rendering.OpenGL.Raw.Core32 |
99 | import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) | 99 | import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) |
100 | import System.IO (hPutStrLn, stderr) | 100 | import System.IO (hPutStrLn, stderr) |
101 | import Unsafe.Coerce | 101 | import Unsafe.Coerce |
102 | 102 | ||
103 | -- | 103 | -- |
104 | -- MANAGEMENT | 104 | -- MANAGEMENT |
105 | -- | 105 | -- |
106 | 106 | ||
107 | -- | A GLSL shader handle. | 107 | -- | A GLSL shader handle. |
108 | data GLSLShader = GLSLShader | 108 | data GLSLShader = GLSLShader |
109 | { getShader :: GLuint | 109 | { getShader :: GLuint |
110 | , getShaderKey :: Resource | 110 | , getShaderKey :: Resource |
111 | } | 111 | } |
112 | 112 | ||
113 | instance ResourceClass GLSLShader where | 113 | instance ResourceClass GLSLShader where |
114 | getResource = getShaderKey | 114 | getResource = getShaderKey |
115 | 115 | ||
116 | -- | A GLSL program handle. | 116 | -- | A GLSL program handle. |
117 | data GLSLProgram = GLSLProgram | 117 | data GLSLProgram = GLSLProgram |
118 | { getProgram :: GLuint | 118 | { getProgram :: GLuint |
119 | , getProgramKey :: Resource | 119 | , getProgramKey :: Resource |
120 | } | 120 | } |
121 | 121 | ||
122 | instance ResourceClass GLSLProgram where | 122 | instance ResourceClass GLSLProgram where |
123 | getResource = getProgramKey | 123 | getResource = getProgramKey |
124 | 124 | ||
125 | -- | Supported shader types. | 125 | -- | Supported shader types. |
126 | data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) | 126 | data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) |
127 | 127 | ||
128 | toGLShader :: ShaderType -> GLenum | 128 | toGLShader :: ShaderType -> GLenum |
129 | toGLShader VertexShader = gl_VERTEX_SHADER | 129 | toGLShader VertexShader = gl_VERTEX_SHADER |
130 | toGLShader FragmentShader = gl_FRAGMENT_SHADER | 130 | toGLShader FragmentShader = gl_FRAGMENT_SHADER |
131 | toGLShader GeometryShader = gl_GEOMETRY_SHADER | 131 | toGLShader GeometryShader = gl_GEOMETRY_SHADER |
132 | 132 | ||
133 | -- | Apply the given function to the program's id. | 133 | -- | Apply the given function to the program's id. |
134 | withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a | 134 | withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a |
135 | withGLSLProgram prog f = f $ getProgram prog | 135 | withGLSLProgram prog f = f $ getProgram prog |
136 | 136 | ||
137 | -- | Get the location of the given uniform variable within the given program. | 137 | -- | Get the location of the given uniform variable within the given program. |
138 | uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint | 138 | uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint |
139 | uniformLocation prog var = makeGettableStateVar $ | 139 | uniformLocation prog var = makeGettableStateVar $ |
140 | withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str) | 140 | withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str) |
141 | 141 | ||
142 | -- | Get or set the location of the given variable to a fragment shader colour number. | 142 | -- | Get or set the location of the given variable to a fragment shader colour number. |
143 | fragLocation :: GLSLProgram -> String -> StateVar GLint | 143 | fragLocation :: GLSLProgram -> String -> StateVar GLint |
144 | fragLocation prog var = makeStateVar get set | 144 | fragLocation prog var = makeStateVar get set |
145 | where | 145 | where |
146 | get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str) | 146 | get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str) |
147 | set idx = withCString var $ \str -> | 147 | set idx = withCString var $ \str -> |
148 | glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) | 148 | glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) |
149 | 149 | ||
150 | -- | Get or set the location of the given attribute within the given program. | 150 | -- | Get or set the location of the given attribute within the given program. |
151 | attribLocation :: GLSLProgram -> String -> StateVar GLint | 151 | attribLocation :: GLSLProgram -> String -> StateVar GLint |
152 | attribLocation prog var = makeStateVar get set | 152 | attribLocation prog var = makeStateVar get set |
153 | where | 153 | where |
154 | get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str) | 154 | get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str) |
155 | set idx = withCString var $ \str -> | 155 | set idx = withCString var $ \str -> |
156 | glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) | 156 | glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) |
157 | 157 | ||
158 | -- | Create a new program. | 158 | -- | Create a new program. |
159 | newProgram :: [GLSLShader] -> Game s GLSLProgram | 159 | newProgram :: [GLSLShader] -> Game s GLSLProgram |
160 | newProgram shaders = do | 160 | newProgram shaders = do |
161 | h <- gameIO glCreateProgram | 161 | h <- gameIO glCreateProgram |
162 | when (h == 0) $ gameError "glCreateProgram failed" | 162 | when (h == 0) $ gameError "glCreateProgram failed" |
163 | rkey <- register $ deleteProgram h | 163 | rkey <- register $ deleteProgram h |
164 | let program = GLSLProgram h rkey | 164 | let program = GLSLProgram h rkey |
165 | mapM_ (gameIO . attachShader program) shaders | 165 | mapM_ (gameIO . attachShader program) shaders |
166 | linkProgram program | 166 | linkProgram program |
167 | return program | 167 | return program |
168 | 168 | ||
169 | -- Delete the program. | 169 | -- Delete the program. |
170 | deleteProgram :: GLuint -> IO () | 170 | deleteProgram :: GLuint -> IO () |
171 | --deleteProgram = glDeleteProgram | 171 | --deleteProgram = glDeleteProgram |
172 | deleteProgram prog = do | 172 | deleteProgram prog = do |
173 | putStrLn $ "Deleting shader program " ++ show prog | 173 | putStrLn $ "Deleting shader program " ++ show prog |
174 | glDeleteProgram prog | 174 | glDeleteProgram prog |
175 | 175 | ||
176 | -- | Link the program. | 176 | -- | Link the program. |
177 | linkProgram :: GLSLProgram -> Game s () | 177 | linkProgram :: GLSLProgram -> Game s () |
178 | linkProgram prog = do | 178 | linkProgram prog = do |
179 | let h = getProgram prog | 179 | let h = getProgram prog |
180 | err <- gameIO $ do | 180 | err <- gameIO $ do |
181 | glLinkProgram h | 181 | glLinkProgram h |
182 | alloca $ \statptr -> do | 182 | alloca $ \statptr -> do |
183 | glGetProgramiv h gl_LINK_STATUS statptr | 183 | glGetProgramiv h gl_LINK_STATUS statptr |
184 | status <- peek statptr | 184 | status <- peek statptr |
185 | case status of | 185 | case status of |
186 | 0 -> getStatus glGetProgramiv glGetProgramInfoLog h | 186 | 0 -> getStatus glGetProgramiv glGetProgramInfoLog h |
187 | _ -> return "" | 187 | _ -> return "" |
188 | 188 | ||
189 | case length err of | 189 | case length err of |
190 | 0 -> return () | 190 | 0 -> return () |
191 | _ -> gameError err | 191 | _ -> gameError err |
192 | 192 | ||
193 | -- | Use the program. | 193 | -- | Use the program. |
194 | useProgram :: GLSLProgram -> IO () | 194 | useProgram :: GLSLProgram -> IO () |
195 | useProgram prog = glUseProgram $ getProgram prog | 195 | useProgram prog = glUseProgram $ getProgram prog |
196 | 196 | ||
197 | -- | Deactivate the active program. | 197 | -- | Deactivate the active program. |
198 | unuseProgram :: IO () | 198 | unuseProgram :: IO () |
199 | unuseProgram = glUseProgram 0 | 199 | unuseProgram = glUseProgram 0 |
200 | 200 | ||
201 | -- | Attach the given shader to the given program. | 201 | -- | Attach the given shader to the given program. |
202 | attachShader :: GLSLProgram -> GLSLShader -> IO () | 202 | attachShader :: GLSLProgram -> GLSLShader -> IO () |
203 | attachShader prog shader = glAttachShader (getProgram prog) (getShader shader) | 203 | attachShader prog shader = glAttachShader (getProgram prog) (getShader shader) |
204 | 204 | ||
205 | -- | Detach the given GLSL from the given program. | 205 | -- | Detach the given GLSL from the given program. |
206 | detachShader :: GLSLProgram -> GLSLShader -> IO () | 206 | detachShader :: GLSLProgram -> GLSLShader -> IO () |
207 | detachShader prog shader = glDetachShader (getProgram prog) (getShader shader) | 207 | detachShader prog shader = glDetachShader (getProgram prog) (getShader shader) |
208 | 208 | ||
209 | -- | Load a shader from the file specified by the given string. | 209 | -- | Load a shader from the file specified by the given string. |
210 | -- | 210 | -- |
211 | -- This function creates a new shader. To load source code into an existing shader, | 211 | -- This function creates a new shader. To load source code into an existing shader, |
212 | -- see 'loadSource', 'shaderSource' and 'readSource'. | 212 | -- see 'loadSource', 'shaderSource' and 'readSource'. |
213 | loadShader :: ShaderType -> FilePath -> Game s GLSLShader | 213 | loadShader :: ShaderType -> FilePath -> Game s GLSLShader |
214 | loadShader shaderType file = do | 214 | loadShader shaderType file = do |
215 | shader <- newShader shaderType | 215 | shader <- newShader shaderType |
216 | loadSource file shader | 216 | loadSource file shader |
217 | compile file shader | 217 | compile file shader |
218 | return shader | 218 | return shader |
219 | 219 | ||
220 | -- | Create a new shader. | 220 | -- | Create a new shader. |
221 | newShader :: ShaderType -> Game s GLSLShader | 221 | newShader :: ShaderType -> Game s GLSLShader |
222 | newShader shaderType = do | 222 | newShader shaderType = do |
223 | h <- gameIO $ glCreateShader (toGLShader shaderType) | 223 | h <- gameIO $ glCreateShader (toGLShader shaderType) |
224 | case h of | 224 | case h of |
225 | 0 -> gameError "glCreateShader failed" | 225 | 0 -> gameError "glCreateShader failed" |
226 | _ -> do | 226 | _ -> do |
227 | rkey <- register $ deleteShader h | 227 | rkey <- register $ deleteShader h |
228 | return $ GLSLShader h rkey | 228 | return $ GLSLShader h rkey |
229 | 229 | ||
230 | -- | Free the shader. | 230 | -- | Free the shader. |
231 | deleteShader :: GLuint -> IO () | 231 | deleteShader :: GLuint -> IO () |
232 | --deleteShader = glDeleteShader | 232 | --deleteShader = glDeleteShader |
233 | deleteShader shader = do | 233 | deleteShader shader = do |
234 | putStrLn $ "Deleting shader " ++ show shader | 234 | putStrLn $ "Deleting shader " ++ show shader |
235 | glDeleteShader shader | 235 | glDeleteShader shader |
236 | 236 | ||
237 | -- | Load a shader source from the file specified by the given string | 237 | -- | Load a shader source from the file specified by the given string |
238 | -- into the shader. | 238 | -- into the shader. |
239 | loadSource :: FilePath -> GLSLShader -> Game s () | 239 | loadSource :: FilePath -> GLSLShader -> Game s () |
240 | loadSource file h = do | 240 | loadSource file h = do |
241 | exists <- gameIO $ doesFileExist file | 241 | exists <- gameIO $ doesFileExist file |
242 | case exists of | 242 | case exists of |
243 | False -> gameError "the specified shader file does not exist" | 243 | False -> gameError "the specified shader file does not exist" |
244 | True -> gameIO $ do | 244 | True -> gameIO $ do |
245 | code <- readSource file | 245 | code <- readSource file |
246 | withCString code $ shaderSource h | 246 | withCString code $ shaderSource h |
247 | 247 | ||
248 | -- | Load the given shader source into the shader. | 248 | -- | Load the given shader source into the shader. |
249 | shaderSource :: GLSLShader -> CString -> IO () | 249 | shaderSource :: GLSLShader -> CString -> IO () |
250 | shaderSource shader str = | 250 | shaderSource shader str = |
251 | let ptr = unsafeCoerce str | 251 | let ptr = unsafeCoerce str |
252 | in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr | 252 | in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr |
253 | 253 | ||
254 | -- | Compile the shader. | 254 | -- | Compile the shader. |
255 | compile :: FilePath -> GLSLShader -> Game s () | 255 | compile :: FilePath -> GLSLShader -> Game s () |
256 | compile file shader = do | 256 | compile file shader = do |
257 | let h = getShader shader | 257 | let h = getShader shader |
258 | 258 | ||
259 | -- Compile | 259 | -- Compile |
260 | gameIO $ glCompileShader h | 260 | gameIO $ glCompileShader h |
261 | 261 | ||
262 | -- Verify status | 262 | -- Verify status |
263 | err <- gameIO $ alloca $ \statusPtr -> do | 263 | err <- gameIO $ alloca $ \statusPtr -> do |
264 | glGetShaderiv h gl_COMPILE_STATUS statusPtr | 264 | glGetShaderiv h gl_COMPILE_STATUS statusPtr |
265 | result <- peek statusPtr | 265 | result <- peek statusPtr |
266 | case result of | 266 | case result of |
267 | 0 -> getStatus glGetShaderiv glGetShaderInfoLog h | 267 | 0 -> getStatus glGetShaderiv glGetShaderInfoLog h |
268 | _ -> return "" | 268 | _ -> return "" |
269 | 269 | ||
270 | case length err of | 270 | case length err of |
271 | 0 -> return () | 271 | 0 -> return () |
272 | _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err | 272 | _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err |
273 | 273 | ||
274 | type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () | 274 | type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () |
275 | type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () | 275 | type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () |
276 | 276 | ||
277 | getStatus :: StatusCall -> LogCall -> GLuint -> IO String | 277 | getStatus :: StatusCall -> LogCall -> GLuint -> IO String |
278 | getStatus getStatus getLog h = do | 278 | getStatus getStatus getLog h = do |
279 | alloca $ \lenPtr -> do | 279 | alloca $ \lenPtr -> do |
280 | getStatus h gl_INFO_LOG_LENGTH lenPtr | 280 | getStatus h gl_INFO_LOG_LENGTH lenPtr |
281 | len <- peek lenPtr | 281 | len <- peek lenPtr |
282 | case len of | 282 | case len of |
283 | 0 -> return "" | 283 | 0 -> return "" |
284 | _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len) | 284 | _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len) |
285 | 285 | ||
286 | getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String | 286 | getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String |
287 | getErrorString getLog h len str = do | 287 | getErrorString getLog h len str = do |
288 | let ptr = unsafeCoerce str | 288 | let ptr = unsafeCoerce str |
289 | getLog h len nullPtr ptr | 289 | getLog h len nullPtr ptr |
290 | peekCString str | 290 | peekCString str |
291 | 291 | ||
292 | -- | Load the shader source specified by the given file. | 292 | -- | Load the shader source specified by the given file. |
293 | -- | 293 | -- |
294 | -- This function implements an #include mechanism, so the given file can | 294 | -- This function implements an #include mechanism, so the given file can |
295 | -- refer to other files. | 295 | -- refer to other files. |
296 | readSource :: FilePath -> IO String | 296 | readSource :: FilePath -> IO String |
297 | readSource = fmap B.unpack . readSource' | 297 | readSource = fmap B.unpack . readSource' |
298 | 298 | ||
299 | readSource' :: FilePath -> IO B.ByteString | 299 | readSource' :: FilePath -> IO B.ByteString |
300 | readSource' file = do | 300 | readSource' file = do |
301 | let includeB = B.pack "#include" | 301 | let includeB = B.pack "#include" |
302 | newLineB = B.pack "\n" | 302 | newLineB = B.pack "\n" |
303 | isInclude = ((==) includeB) . B.take 8 | 303 | isInclude = ((==) includeB) . B.take 8 |
304 | clean = B.dropWhile (\c -> c == ' ') | 304 | clean = B.dropWhile (\c -> c == ' ') |
305 | cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ') | 305 | cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ') |
306 | toLines = B.splitWith (\c -> c == '\n' || c == '\r') | 306 | toLines = B.splitWith (\c -> c == '\n' || c == '\r') |
307 | addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s | 307 | addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s |
308 | parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence . | 308 | parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence . |
309 | fmap (processLine . clean) . toLines | 309 | fmap (processLine . clean) . toLines |
310 | processLine l = | 310 | processLine l = |
311 | if isInclude l | 311 | if isInclude l |
312 | then readSource' $ B.unpack . clean . cleanInclude $ l | 312 | then readSource' $ B.unpack . clean . cleanInclude $ l |
313 | else return l | 313 | else return l |
314 | 314 | ||
315 | contents <- B.readFile file | 315 | contents <- B.readFile file |
316 | 316 | ||
317 | dir <- getCurrentDirectory | 317 | dir <- getCurrentDirectory |
318 | let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file | 318 | let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file |
319 | 319 | ||
320 | setCurrentDirectory dir' | 320 | setCurrentDirectory dir' |
321 | code <- parse contents | 321 | code <- parse contents |
322 | setCurrentDirectory dir | 322 | setCurrentDirectory dir |
323 | 323 | ||
324 | return code | 324 | return code |
325 | 325 | ||
326 | class Uniform a where | 326 | class Uniform a where |
327 | -- | Load a list of uniform values. | 327 | -- | Load a list of uniform values. |
328 | uniform :: GLint -> a -> IO () | 328 | uniform :: GLint -> a -> IO () |
329 | 329 | ||
330 | instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) | 330 | instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) |
331 | instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a) | 331 | instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a) |
332 | 332 | instance Uniform CFloat where uniform loc a = glUniform1f loc a | |
333 | instance Uniform (Int,Int) where | 333 | |
334 | uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y) | 334 | instance Uniform (Int,Int) where |
335 | 335 | uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y) | |
336 | instance Uniform (Float,Float) where | 336 | |
337 | uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y) | 337 | instance Uniform (Float,Float) where |
338 | 338 | uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y) | |
339 | instance Uniform (Int,Int,Int) where | 339 | |
340 | uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z) | 340 | instance Uniform (Int,Int,Int) where |
341 | 341 | uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z) | |
342 | instance Uniform (Float,Float,Float) where | 342 | |
343 | uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) | 343 | instance Uniform (Float,Float,Float) where |
344 | 344 | uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) | |
345 | instance Uniform (Int,Int,Int,Int) where | 345 | |
346 | uniform loc (x,y,z,w) = glUniform4i loc | 346 | instance Uniform (Int,Int,Int,Int) where |
347 | (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) | 347 | uniform loc (x,y,z,w) = glUniform4i loc |
348 | 348 | (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) | |
349 | instance Uniform (Float,Float,Float,Float) where | 349 | |
350 | uniform loc (x,y,z,w) = glUniform4f loc | 350 | instance Uniform (Float,Float,Float,Float) where |
351 | (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) (unsafeCoerce w) | 351 | uniform loc (x,y,z,w) = glUniform4f loc |
352 | 352 | (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) (unsafeCoerce w) | |
353 | instance Uniform Vector2 where | 353 | |
354 | uniform loc v = glUniform2f loc x' y' | 354 | instance Uniform Vector2 where |
355 | where x' = unsafeCoerce $ x v | 355 | uniform loc v = glUniform2f loc x' y' |
356 | y' = unsafeCoerce $ y v | 356 | where x' = unsafeCoerce $ x v |
357 | 357 | y' = unsafeCoerce $ y v | |
358 | instance Uniform Vector3 where | 358 | |
359 | uniform loc v = glUniform3f loc x' y' z' | 359 | instance Uniform Vector3 where |
360 | where x' = unsafeCoerce $ x v | 360 | uniform loc v = glUniform3f loc x' y' z' |
361 | y' = unsafeCoerce $ y v | 361 | where x' = unsafeCoerce $ x v |
362 | z' = unsafeCoerce $ z v | 362 | y' = unsafeCoerce $ y v |
363 | 363 | z' = unsafeCoerce $ z v | |
364 | instance Uniform Vector4 where | 364 | |
365 | uniform loc v = glUniform4f loc x' y' z' w' | 365 | instance Uniform Vector4 where |
366 | where x' = unsafeCoerce $ x v | 366 | uniform loc v = glUniform4f loc x' y' z' w' |
367 | y' = unsafeCoerce $ y v | 367 | where x' = unsafeCoerce $ x v |
368 | z' = unsafeCoerce $ z v | 368 | y' = unsafeCoerce $ y v |
369 | w' = unsafeCoerce $ w v | 369 | z' = unsafeCoerce $ z v |
370 | 370 | w' = unsafeCoerce $ w v | |
371 | instance Uniform Matrix3 where | 371 | |
372 | uniform loc mat = | 372 | instance Uniform Matrix3 where |
373 | with mat $ \ptrMat -> | 373 | uniform loc mat = |
374 | glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) | 374 | with mat $ \ptrMat -> |
375 | 375 | glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) | |
376 | instance Uniform Matrix4 where | 376 | |
377 | uniform loc mat = | 377 | instance Uniform Matrix4 where |
378 | with mat $ \ptrMat -> | 378 | uniform loc mat = |
379 | glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) | 379 | with mat $ \ptrMat -> |
380 | 380 | glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) | |
381 | instance Uniform [Float] where | 381 | |
382 | uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr -> | 382 | instance Uniform [Float] where |
383 | case length vals of | 383 | uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr -> |
384 | 1 -> glUniform1fv loc 1 ptr | 384 | case length vals of |
385 | 2 -> glUniform2fv loc 1 ptr | 385 | 1 -> glUniform1fv loc 1 ptr |
386 | 3 -> glUniform3fv loc 1 ptr | 386 | 2 -> glUniform2fv loc 1 ptr |
387 | 4 -> glUniform4fv loc 1 ptr | 387 | 3 -> glUniform3fv loc 1 ptr |
388 | 388 | 4 -> glUniform4fv loc 1 ptr | |
389 | instance Uniform [Int] where | 389 | |
390 | uniform loc vals = withArray (map fromIntegral vals) $ \ptr -> | 390 | instance Uniform [CFloat] where |
391 | case length vals of | 391 | uniform loc vals = withArray vals $ \ptr -> |
392 | 1 -> glUniform1iv loc 1 ptr | 392 | case length vals of |
393 | 2 -> glUniform2iv loc 1 ptr | 393 | 1 -> glUniform1fv loc 1 ptr |
394 | 3 -> glUniform3iv loc 1 ptr | 394 | 2 -> glUniform2fv loc 1 ptr |
395 | 4 -> glUniform4iv loc 1 ptr | 395 | 3 -> glUniform3fv loc 1 ptr |
396 | 396 | 4 -> glUniform4fv loc 1 ptr | |
397 | -- | 397 | |
398 | -- VAOs | 398 | instance Uniform [Int] where |
399 | -- | 399 | uniform loc vals = withArray (map fromIntegral vals) $ \ptr -> |
400 | 400 | case length vals of | |
401 | -- | A vertex array object. | 401 | 1 -> glUniform1iv loc 1 ptr |
402 | data VAO = VAO | 402 | 2 -> glUniform2iv loc 1 ptr |
403 | { getVAO :: GLuint | 403 | 3 -> glUniform3iv loc 1 ptr |
404 | , vaoKey :: Resource | 404 | 4 -> glUniform4iv loc 1 ptr |
405 | } | 405 | |
406 | 406 | -- | |
407 | instance ResourceClass VAO where | 407 | -- VAOs |
408 | getResource = vaoKey | 408 | -- |
409 | 409 | ||
410 | instance Eq VAO where | 410 | -- | A vertex array object. |
411 | vao1 == vao2 = getVAO vao1 == getVAO vao2 | 411 | data VAO = VAO |
412 | 412 | { getVAO :: GLuint | |
413 | instance Ord VAO where | 413 | , vaoKey :: Resource |
414 | vao1 < vao2 = getVAO vao1 < getVAO vao2 | 414 | } |
415 | 415 | ||
416 | -- | Create a new vao. | 416 | instance ResourceClass VAO where |
417 | newVAO :: Game s VAO | 417 | getResource = vaoKey |
418 | newVAO = do | 418 | |
419 | h <- gameIO . alloca $ \ptr -> do | 419 | instance Eq VAO where |
420 | glGenVertexArrays 1 ptr | 420 | vao1 == vao2 = getVAO vao1 == getVAO vao2 |
421 | peek ptr | 421 | |
422 | 422 | instance Ord VAO where | |
423 | rkey <- register $ deleteVAO h | 423 | vao1 < vao2 = getVAO vao1 < getVAO vao2 |
424 | return $ VAO h rkey | 424 | |
425 | 425 | -- | Create a new vao. | |
426 | -- | Delete the vao. | 426 | newVAO :: Game s VAO |
427 | deleteVAO :: GLuint -> IO () | 427 | newVAO = do |
428 | deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 | 428 | h <- gameIO . alloca $ \ptr -> do |
429 | 429 | glGenVertexArrays 1 ptr | |
430 | -- | Bind the vao. | 430 | peek ptr |
431 | bindVAO :: VAO -> IO () | 431 | |
432 | bindVAO = glBindVertexArray . getVAO | 432 | rkey <- register $ deleteVAO h |
433 | 433 | return $ VAO h rkey | |
434 | -- | Unbind the bound vao. | 434 | |
435 | unbindVAO :: IO () | 435 | -- | Delete the vao. |
436 | unbindVAO = glBindVertexArray 0 | 436 | deleteVAO :: GLuint -> IO () |
437 | 437 | deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 | |
438 | -- | Enable the given vertex attribute of the bound vao. | 438 | |
439 | -- | 439 | -- | Bind the vao. |
440 | -- See also 'bindVAO'. | 440 | bindVAO :: VAO -> IO () |
441 | enableVAOAttrib :: GLuint -- ^ Attribute index. | 441 | bindVAO = glBindVertexArray . getVAO |
442 | -> IO () | 442 | |
443 | enableVAOAttrib = glEnableVertexAttribArray | 443 | -- | Unbind the bound vao. |
444 | 444 | unbindVAO :: IO () | |
445 | -- | Bind the bound buffer to the given point. | 445 | unbindVAO = glBindVertexArray 0 |
446 | attribVAOPointer | 446 | |
447 | :: GLuint -- ^ The index of the generic vertex attribute to be modified. | 447 | -- | Enable the given vertex attribute of the bound vao. |
448 | -> GLint -- ^ The number of components per generic vertex attribute. Must be 1,2,3,4. | 448 | -- |
449 | -> GLenum -- ^ The data type of each component in the array. | 449 | -- See also 'bindVAO'. |
450 | -> Bool -- ^ Whether fixed-point data values should be normalized. | 450 | enableVAOAttrib :: GLuint -- ^ Attribute index. |
451 | -> GLsizei -- ^ Stride. Byte offset between consecutive generic vertex attributes. | 451 | -> IO () |
452 | -> Int -- ^ Offset to the first component in the array. | 452 | enableVAOAttrib = glEnableVertexAttribArray |
453 | -> IO () | 453 | |
454 | attribVAOPointer idx ncomp dattype normalise stride off = | 454 | -- | Bind the bound buffer to the given point. |
455 | glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off) | 455 | attribVAOPointer |
456 | where normalise' = if normalise then 1 else 0 | 456 | :: GLuint -- ^ The index of the generic vertex attribute to be modified. |
457 | 457 | -> GLint -- ^ The number of components per generic vertex attribute. Must be 1,2,3,4. | |
458 | -- | Draw the bound vao. | 458 | -> GLenum -- ^ The data type of each component in the array. |
459 | drawArrays | 459 | -> Bool -- ^ Whether fixed-point data values should be normalized. |
460 | :: GLenum -- ^ The kind of primitives to render. | 460 | -> GLsizei -- ^ Stride. Byte offset between consecutive generic vertex attributes. |
461 | -> Int -- ^ Starting index in the enabled arrays. | 461 | -> Int -- ^ Offset to the first component in the array. |
462 | -> Int -- ^ The number of indices to be rendered. | 462 | -> IO () |
463 | -> IO () | 463 | attribVAOPointer idx ncomp dattype normalise stride off = |
464 | drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) | 464 | glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off) |
465 | 465 | where normalise' = if normalise then 1 else 0 | |
466 | -- | Draw the bound vao, indexed mode. | 466 | |
467 | drawElements | 467 | -- | Draw the bound vao. |
468 | :: GLenum -- ^ The kind of primitives to render. | 468 | drawArrays |
469 | -> Int -- ^ The number of elements to be rendered. | 469 | :: GLenum -- ^ The kind of primitives to render. |
470 | -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT. | 470 | -> Int -- ^ Starting index in the enabled arrays. |
471 | -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer. | 471 | -> Int -- ^ The number of indices to be rendered. |
472 | -> IO () | 472 | -> IO () |
473 | drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs | 473 | drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) |
474 | 474 | ||
475 | -- | 475 | -- | Draw the bound vao, indexed mode. |
476 | -- BUFFER | 476 | drawElements |
477 | -- | 477 | :: GLenum -- ^ The kind of primitives to render. |
478 | 478 | -> Int -- ^ The number of elements to be rendered. | |
479 | -- | An OpenGL buffer. | 479 | -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT. |
480 | data GLBuffer = GLBuffer | 480 | -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer. |
481 | { getBuffer :: GLuint | 481 | -> IO () |
482 | , rkey :: Resource | 482 | drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs |
483 | } | 483 | |
484 | 484 | -- | |
485 | instance ResourceClass GLBuffer where | 485 | -- BUFFER |
486 | getResource = rkey | 486 | -- |
487 | 487 | ||
488 | -- | The type of target buffer. | 488 | -- | An OpenGL buffer. |
489 | data TargetBuffer | 489 | data GLBuffer = GLBuffer |
490 | = ArrayBuffer | 490 | { getBuffer :: GLuint |
491 | | ElementArrayBuffer | 491 | , rkey :: Resource |
492 | | PixelPackBuffer | 492 | } |
493 | | PixelUnpackBuffer | 493 | |
494 | deriving (Eq, Show) | 494 | instance ResourceClass GLBuffer where |
495 | 495 | getResource = rkey | |
496 | fromTarget :: TargetBuffer -> GLenum | 496 | |
497 | fromTarget ArrayBuffer = gl_ARRAY_BUFFER | 497 | -- | The type of target buffer. |
498 | fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER | 498 | data TargetBuffer |
499 | fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER | 499 | = ArrayBuffer |
500 | fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER | 500 | | ElementArrayBuffer |
501 | 501 | | PixelPackBuffer | |
502 | -- | A buffer usage. | 502 | | PixelUnpackBuffer |
503 | data BufferUsage | 503 | deriving (Eq, Show) |
504 | = StreamDraw | 504 | |
505 | | StreamRead | 505 | fromTarget :: TargetBuffer -> GLenum |
506 | | StreamCopy | 506 | fromTarget ArrayBuffer = gl_ARRAY_BUFFER |
507 | | StaticDraw | 507 | fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER |
508 | | StaticRead | 508 | fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER |
509 | | StaticCopy | 509 | fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER |
510 | | DynamicDraw | 510 | |
511 | | DynamicRead | 511 | -- | A buffer usage. |
512 | | DynamicCopy | 512 | data BufferUsage |
513 | deriving (Eq, Show) | 513 | = StreamDraw |
514 | 514 | | StreamRead | |
515 | fromUsage :: BufferUsage -> GLenum | 515 | | StreamCopy |
516 | fromUsage StreamDraw = gl_STREAM_DRAW | 516 | | StaticDraw |
517 | fromUsage StreamRead = gl_STREAM_READ | 517 | | StaticRead |
518 | fromUsage StreamCopy = gl_STREAM_COPY | 518 | | StaticCopy |
519 | fromUsage StaticDraw = gl_STATIC_DRAW | 519 | | DynamicDraw |
520 | fromUsage StaticRead = gl_STATIC_READ | 520 | | DynamicRead |
521 | fromUsage StaticCopy = gl_STATIC_COPY | 521 | | DynamicCopy |
522 | fromUsage DynamicDraw = gl_DYNAMIC_DRAW | 522 | deriving (Eq, Show) |
523 | fromUsage DynamicRead = gl_DYNAMIC_READ | 523 | |
524 | fromUsage DynamicCopy = gl_DYNAMIC_COPY | 524 | fromUsage :: BufferUsage -> GLenum |
525 | 525 | fromUsage StreamDraw = gl_STREAM_DRAW | |
526 | -- | Create a new buffer. | 526 | fromUsage StreamRead = gl_STREAM_READ |
527 | newBuffer :: Game s GLBuffer | 527 | fromUsage StreamCopy = gl_STREAM_COPY |
528 | newBuffer = do | 528 | fromUsage StaticDraw = gl_STATIC_DRAW |
529 | h <- gameIO . alloca $ \ptr -> do | 529 | fromUsage StaticRead = gl_STATIC_READ |
530 | glGenBuffers 1 ptr | 530 | fromUsage StaticCopy = gl_STATIC_COPY |
531 | peek ptr | 531 | fromUsage DynamicDraw = gl_DYNAMIC_DRAW |
532 | 532 | fromUsage DynamicRead = gl_DYNAMIC_READ | |
533 | rkey <- register $ deleteBuffer h | 533 | fromUsage DynamicCopy = gl_DYNAMIC_COPY |
534 | return $ GLBuffer h rkey | 534 | |
535 | 535 | -- | Create a new buffer. | |
536 | -- | Delete the buffer. | 536 | newBuffer :: Game s GLBuffer |
537 | deleteBuffer :: GLuint -> IO () | 537 | newBuffer = do |
538 | deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 | 538 | h <- gameIO . alloca $ \ptr -> do |
539 | 539 | glGenBuffers 1 ptr | |
540 | -- | Bind the buffer. | 540 | peek ptr |
541 | bindBuffer :: GLBuffer -> TargetBuffer -> IO () | 541 | |
542 | bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf | 542 | rkey <- register $ deleteBuffer h |
543 | 543 | return $ GLBuffer h rkey | |
544 | -- | Unbind the bound buffer. | 544 | |
545 | unbindBuffer :: TargetBuffer -> IO () | 545 | -- | Delete the buffer. |
546 | unbindBuffer target = glBindBuffer (fromTarget target) 0 | 546 | deleteBuffer :: GLuint -> IO () |
547 | 547 | deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 | |
548 | class Storable a => BufferData a where | 548 | |
549 | -- | Set the buffer's data. | 549 | -- | Bind the buffer. |
550 | bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO () | 550 | bindBuffer :: TargetBuffer -> GLBuffer -> IO () |
551 | bufferData tgt vals usage = | 551 | bindBuffer target buf = glBindBuffer (fromTarget target) $ getBuffer buf |
552 | let n = sizeOf (head vals) * length vals | 552 | |
553 | in withArray vals $ \ptr -> bufferData' tgt n ptr usage | 553 | -- | Unbind the bound buffer. |
554 | 554 | unbindBuffer :: TargetBuffer -> IO () | |
555 | instance BufferData Word8 | 555 | unbindBuffer target = glBindBuffer (fromTarget target) 0 |
556 | instance BufferData Word16 | 556 | |
557 | instance BufferData Word32 | 557 | class Storable a => BufferData a where |
558 | instance BufferData CChar | 558 | -- | Set the buffer's data. |
559 | instance BufferData CInt | 559 | bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO () |
560 | instance BufferData CFloat | 560 | bufferData tgt vals usage = |
561 | instance BufferData CDouble | 561 | let n = sizeOf (head vals) * length vals |
562 | instance BufferData Int | 562 | in withArray vals $ \ptr -> bufferData' tgt n ptr usage |
563 | instance BufferData Float | 563 | |
564 | instance BufferData Double | 564 | instance BufferData Word8 |
565 | 565 | instance BufferData Word16 | |
566 | {-bufferData :: Storable a | 566 | instance BufferData Word32 |
567 | => TargetBuffer | 567 | instance BufferData CChar |
568 | -> Int -- ^ The size in bytes of an element in the data list. | 568 | instance BufferData CInt |
569 | -> [a] -- ^ The data list. | 569 | instance BufferData CFloat |
570 | -> BufferUsage | 570 | instance BufferData CDouble |
571 | -> IO () | 571 | instance BufferData Int |
572 | bufferData target n bufData usage = withArray bufData $ | 572 | instance BufferData Float |
573 | \ptr -> bufferData target (n * length bufData) ptr usage-} | 573 | instance BufferData Double |
574 | 574 | ||
575 | -- | Set the buffer's data. | 575 | {-bufferData :: Storable a |
576 | bufferData' :: TargetBuffer | 576 | => TargetBuffer |
577 | -> Int -- ^ Buffer size in bytes. | 577 | -> Int -- ^ The size in bytes of an element in the data list. |
578 | -> Ptr a | 578 | -> [a] -- ^ The data list. |
579 | -> BufferUsage | 579 | -> BufferUsage |
580 | -> IO () | 580 | -> IO () |
581 | bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) | 581 | bufferData target n bufData usage = withArray bufData $ |
582 | 582 | \ptr -> bufferData target (n * length bufData) ptr usage-} | |
583 | -- | Apply the given function the buffer's id. | 583 | |
584 | withGLBuffer :: GLBuffer -> (GLuint -> a) -> a | 584 | -- | Set the buffer's data. |
585 | withGLBuffer buf f = f $ getBuffer buf | 585 | bufferData' :: TargetBuffer |
586 | 586 | -> Int -- ^ Buffer size in bytes. | |
587 | -- | 587 | -> Ptr a |
588 | -- TEXTURE | 588 | -> BufferUsage |
589 | -- | 589 | -> IO () |
590 | 590 | bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) | |
591 | -- | Represents a texture resource. | 591 | |
592 | data Texture = Texture | 592 | -- | Apply the given function the buffer's id. |
593 | { getTex :: GLuint | 593 | withGLBuffer :: GLBuffer -> (GLuint -> a) -> a |
594 | , texKey :: Resource | 594 | withGLBuffer buf f = f $ getBuffer buf |
595 | } | 595 | |
596 | 596 | -- | |
597 | instance Eq Texture where | 597 | -- TEXTURE |
598 | t1 == t2 = getTex t1 == getTex t2 | 598 | -- |
599 | 599 | ||
600 | instance Ord Texture where | 600 | -- | Represents a texture resource. |
601 | t1 < t2 = getTex t1 < getTex t2 | 601 | data Texture = Texture |
602 | 602 | { getTex :: GLuint | |
603 | instance ResourceClass Texture where | 603 | , texKey :: Resource |
604 | getResource = texKey | 604 | } |
605 | 605 | ||
606 | -- | Create a new texture. | 606 | instance Eq Texture where |
607 | newTexture :: Game s Texture | 607 | t1 == t2 = getTex t1 == getTex t2 |
608 | newTexture = do | 608 | |
609 | tex <- gameIO . alloca $ \ptr -> do | 609 | instance Ord Texture where |
610 | glGenTextures 1 ptr | 610 | t1 < t2 = getTex t1 < getTex t2 |
611 | peek ptr | 611 | |
612 | 612 | instance ResourceClass Texture where | |
613 | rkey <- register $ deleteTexture tex | 613 | getResource = texKey |
614 | return $ Texture tex rkey | 614 | |
615 | 615 | -- | Create a new texture. | |
616 | -- | Delete the texture. | 616 | newTexture :: Game s Texture |
617 | deleteTexture :: GLuint -> IO () | 617 | newTexture = do |
618 | --deleteTexture tex = with tex $ glDeleteTextures 1 | 618 | tex <- gameIO . alloca $ \ptr -> do |
619 | deleteTexture tex = do | 619 | glGenTextures 1 ptr |
620 | putStrLn $ "Releasing texture " ++ show tex | 620 | peek ptr |
621 | with tex $ glDeleteTextures 1 | 621 | |
622 | 622 | rkey <- register $ deleteTexture tex | |
623 | -- | Load the 'Texture' specified by the given file. | 623 | return $ Texture tex rkey |
624 | loadTextureImage :: FilePath | 624 | |
625 | -> GLenum -- ^ Texture's min filter. | 625 | -- | Delete the texture. |
626 | -> GLenum -- ^ Texture's mag filter. | 626 | deleteTexture :: GLuint -> IO () |
627 | -> Game s Texture | 627 | --deleteTexture tex = with tex $ glDeleteTextures 1 |
628 | loadTextureImage file minFilter magFilter = do | 628 | deleteTexture tex = do |
629 | image <- loadImage file | 629 | putStrLn $ "Releasing texture " ++ show tex |
630 | tex <- newTexture | 630 | with tex $ glDeleteTextures 1 |
631 | gameIO $ do | 631 | |
632 | let w = width image | 632 | -- | Load the 'Texture' specified by the given file. |
633 | h = height image | 633 | loadTextureImage :: FilePath |
634 | pix = pixels image | 634 | -> GLenum -- ^ Texture's min filter. |
635 | rgb = fromIntegral . fromEnum $ gl_RGB | 635 | -> GLenum -- ^ Texture's mag filter. |
636 | 636 | -> Game s Texture | |
637 | bindTexture tex | 637 | loadTextureImage file minFilter magFilter = do |
638 | loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix | 638 | image <- loadImage file |
639 | texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter | 639 | tex <- newTexture |
640 | texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter | 640 | gameIO $ do |
641 | 641 | let w = width image | |
642 | return tex | 642 | h = height image |
643 | 643 | pix = pixels image | |
644 | -- | Bind the texture. | 644 | rgb = fromIntegral . fromEnum $ gl_RGB |
645 | bindTexture :: Texture -> IO () | 645 | |
646 | bindTexture = glBindTexture gl_TEXTURE_2D . getTex | 646 | bindTexture tex |
647 | 647 | loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix | |
648 | -- | Unbind the bound texture. | 648 | texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter |
649 | unbindTexture :: IO () | 649 | texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter |
650 | unbindTexture = glBindTexture gl_TEXTURE_2D 0 | 650 | |
651 | 651 | return tex | |
652 | -- | Load data onto the bound texture. | 652 | |
653 | -- | 653 | -- | Bind the texture. |
654 | -- See also 'bindTexture'. | 654 | bindTexture :: Texture -> IO () |
655 | loadTextureData :: GLenum | 655 | bindTexture = glBindTexture gl_TEXTURE_2D . getTex |
656 | -> Int -- ^ Target | 656 | |
657 | -> Int -- ^ Level | 657 | -- | Unbind the bound texture. |
658 | -> Int -- ^ Internal format | 658 | unbindTexture :: IO () |
659 | -> Int -- ^ Width | 659 | unbindTexture = glBindTexture gl_TEXTURE_2D 0 |
660 | -> Int -- ^ Height | 660 | |
661 | -> GLenum -- ^ Border | 661 | -- | Load data onto the bound texture. |
662 | -> GLenum -- ^ Texture type | 662 | -- |
663 | -> Ptr a -- ^ Texture data | 663 | -- See also 'bindTexture'. |
664 | -> IO () | 664 | loadTextureData :: GLenum |
665 | loadTextureData target level internalFormat width height border format texType texData = do | 665 | -> Int -- ^ Target |
666 | glTexImage2D target | 666 | -> Int -- ^ Level |
667 | (fromIntegral level) | 667 | -> Int -- ^ Internal format |
668 | (fromIntegral internalFormat) | 668 | -> Int -- ^ Width |
669 | (fromIntegral width) | 669 | -> Int -- ^ Height |
670 | (fromIntegral height) | 670 | -> GLenum -- ^ Border |
671 | (fromIntegral border) | 671 | -> GLenum -- ^ Texture type |
672 | (fromIntegral format) | 672 | -> Ptr a -- ^ Texture data |
673 | texType | 673 | -> IO () |
674 | texData | 674 | loadTextureData target level internalFormat width height border format texType texData = do |
675 | 675 | glTexImage2D target | |
676 | -- | Set the bound texture's parameter to the given value. | 676 | (fromIntegral level) |
677 | texParami :: GLenum -> GLenum -> SettableStateVar GLenum | 677 | (fromIntegral internalFormat) |
678 | texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val | 678 | (fromIntegral width) |
679 | 679 | (fromIntegral height) | |
680 | -- | Set the bound texture's parameter to the given value. | 680 | (fromIntegral border) |
681 | texParamf :: GLenum -> GLenum -> SettableStateVar Float | 681 | (fromIntegral format) |
682 | texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) | 682 | texType |
683 | 683 | texData | |
684 | -- | Set the active texture unit. | 684 | |
685 | activeTexture :: SettableStateVar GLenum | 685 | -- | Set the bound texture's parameter to the given value. |
686 | activeTexture = makeSettableStateVar glActiveTexture | 686 | texParami :: GLenum -> GLenum -> SettableStateVar GLenum |
687 | 687 | texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val | |
688 | -- | 688 | |
689 | -- ERROR | 689 | -- | Set the bound texture's parameter to the given value. |
690 | -- | 690 | texParamf :: GLenum -> GLenum -> SettableStateVar Float |
691 | 691 | texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) | |
692 | -- | Get the last OpenGL error. | 692 | |
693 | getGLError :: IO (Maybe String) | 693 | -- | Set the active texture unit. |
694 | getGLError = fmap translate glGetError | 694 | activeTexture :: SettableStateVar GLenum |
695 | where | 695 | activeTexture = makeSettableStateVar glActiveTexture |
696 | translate err | 696 | |
697 | | err == gl_NO_ERROR = Nothing | 697 | -- |
698 | | err == gl_INVALID_ENUM = Just "Invalid enum" | 698 | -- ERROR |
699 | | err == gl_INVALID_VALUE = Just "Invalid value" | 699 | -- |
700 | | err == gl_INVALID_OPERATION = Just "Invalid operation" | 700 | |
701 | | err == gl_OUT_OF_MEMORY = Just "Out of memory" | 701 | -- | Get the last OpenGL error. |
702 | | otherwise = Just "Unknown error" | 702 | getGLError :: IO (Maybe String) |
703 | 703 | getGLError = fmap translate glGetError | |
704 | -- | Print the last OpenGL error. | 704 | where |
705 | printGLError :: IO () | 705 | translate err |
706 | printGLError = getGLError >>= \err -> case err of | 706 | | err == gl_NO_ERROR = Nothing |
707 | Nothing -> return () | 707 | | err == gl_INVALID_ENUM = Just "Invalid enum" |
708 | Just str -> hPutStrLn stderr str | 708 | | err == gl_INVALID_VALUE = Just "Invalid value" |
709 | 709 | | err == gl_INVALID_OPERATION = Just "Invalid operation" | |
710 | -- | Run the given setup action and check for OpenGL errors. | 710 | | err == gl_OUT_OF_MEMORY = Just "Out of memory" |
711 | -- | 711 | | otherwise = Just "Unknown error" |
712 | -- If an OpenGL error is produced, an exception is thrown containing | 712 | |
713 | -- the given string appended to the string describing the error. | 713 | -- | Print the last OpenGL error. |
714 | assertGL :: Game s a -> String -> Game s a | 714 | printGLError :: IO () |
715 | assertGL action err = do | 715 | printGLError = getGLError >>= \err -> case err of |
716 | result <- action | 716 | Nothing -> return () |
717 | status <- gameIO getGLError | 717 | Just str -> hPutStrLn stderr str |
718 | case status of | 718 | |
719 | Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str | 719 | -- | Run the given setup action and check for OpenGL errors. |
720 | Nothing -> return result | 720 | -- |
721 | -- If an OpenGL error is produced, an exception is thrown containing | ||
722 | -- the given string appended to the string describing the error. | ||
723 | assertGL :: Game s a -> String -> Game s a | ||
724 | assertGL action err = do | ||
725 | result <- action | ||
726 | status <- gameIO getGLError | ||
727 | case status of | ||
728 | Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str | ||
729 | Nothing -> return result | ||
diff --git a/Spear/Game.hs b/Spear/Game.hs index cf33ccb..bf58c82 100644 --- a/Spear/Game.hs +++ b/Spear/Game.hs | |||
@@ -1,98 +1,101 @@ | |||
1 | module Spear.Game | 1 | module Spear.Game |
2 | ( | 2 | ( |
3 | Game | 3 | Game |
4 | , Resource | 4 | , Resource |
5 | , ResourceClass(..) | 5 | , ResourceClass(..) |
6 | -- * Game State | 6 | -- * Game state |
7 | , getGameState | 7 | , getGameState |
8 | , saveGameState | 8 | , saveGameState |
9 | , modifyGameState | 9 | , modifyGameState |
10 | -- * Game Resources | 10 | -- * Game resources |
11 | , register | 11 | , register |
12 | , unregister | 12 | , unregister |
13 | , gameError | 13 | -- * Error handling |
14 | , assertMaybe | 14 | , gameError |
15 | -- * Running and IO | 15 | , assertMaybe |
16 | , runGame | 16 | , catchGameError |
17 | , runGame' | 17 | , catchGameErrorFinally |
18 | , runSubGame | 18 | -- * Running and IO |
19 | , runSubGame' | 19 | , runGame |
20 | , evalSubGame | 20 | , runSubGame |
21 | , execSubGame | 21 | , evalSubGame |
22 | , gameIO | 22 | , execSubGame |
23 | ) | 23 | , gameIO |
24 | where | 24 | ) |
25 | 25 | where | |
26 | import Control.Monad.Trans.Class (lift) | 26 | |
27 | import Control.Monad.State.Strict | 27 | import Control.Monad.Trans.Class (lift) |
28 | import Control.Monad.Error | 28 | import Control.Monad.State.Strict |
29 | import qualified Control.Monad.Trans.Resource as R | 29 | import Control.Monad.Error |
30 | 30 | import qualified Control.Monad.Trans.Resource as R | |
31 | type Resource = R.ReleaseKey | 31 | |
32 | type Game s = StateT s (R.ResourceT (ErrorT String IO)) | 32 | type Resource = R.ReleaseKey |
33 | 33 | type Game s = StateT s (R.ResourceT (ErrorT String IO)) | |
34 | class ResourceClass a where | 34 | |
35 | getResource :: a -> Resource | 35 | class ResourceClass a where |
36 | 36 | getResource :: a -> Resource | |
37 | release :: a -> Game s () | 37 | |
38 | release = unregister . getResource | 38 | release :: a -> Game s () |
39 | 39 | release = unregister . getResource | |
40 | clean :: a -> IO () | 40 | |
41 | clean = R.release . getResource | 41 | clean :: a -> IO () |
42 | 42 | clean = R.release . getResource | |
43 | -- | Retrieve the game state. | 43 | |
44 | getGameState :: Game s s | 44 | -- | Retrieve the game state. |
45 | getGameState = get | 45 | getGameState :: Game s s |
46 | 46 | getGameState = get | |
47 | -- | Save the game state. | 47 | |
48 | saveGameState :: s -> Game s () | 48 | -- | Save the game state. |
49 | saveGameState = put | 49 | saveGameState :: s -> Game s () |
50 | 50 | saveGameState = put | |
51 | -- | Modify the game state. | 51 | |
52 | modifyGameState :: (s -> s) -> Game s () | 52 | -- | Modify the game state. |
53 | modifyGameState = modify | 53 | modifyGameState :: (s -> s) -> Game s () |
54 | 54 | modifyGameState = modify | |
55 | -- | Register the given cleaner. | 55 | |
56 | register :: IO () -> Game s Resource | 56 | -- | Register the given cleaner. |
57 | register = lift . R.register | 57 | register :: IO () -> Game s Resource |
58 | 58 | register = lift . R.register | |
59 | -- | Release the given 'Resource'. | 59 | |
60 | unregister :: Resource -> Game s () | 60 | -- | Release the given 'Resource'. |
61 | unregister = lift . R.release | 61 | unregister :: Resource -> Game s () |
62 | 62 | unregister = lift . R.release | |
63 | -- | Throw an error from the 'Game' monad. | 63 | |
64 | gameError :: String -> Game s a | 64 | -- | Throw an error from the 'Game' monad. |
65 | gameError = lift . lift . throwError | 65 | gameError :: String -> Game s a |
66 | 66 | gameError = lift . lift . throwError | |
67 | -- | Throw the given error string if given 'Nothing'. | 67 | |
68 | assertMaybe :: Maybe a -> String -> Game s a | 68 | -- | Throw the given error string if given 'Nothing'. |
69 | assertMaybe Nothing err = gameError err | 69 | assertMaybe :: Maybe a -> String -> Game s a |
70 | assertMaybe (Just x) _ = return x | 70 | assertMaybe Nothing err = gameError err |
71 | 71 | assertMaybe (Just x) _ = return x | |
72 | -- | Run the given game. | 72 | |
73 | runGame :: Game s a -> s -> IO (Either String (a,s)) | 73 | -- | Run the given game with the given error handler. |
74 | runGame game state = runErrorT . R.runResourceT . runStateT game $ state | 74 | catchGameError :: Game s a -> (String -> Game s a) -> Game s a |
75 | 75 | catchGameError game catch = catchError game catch | |
76 | -- | Run the given game. | 76 | |
77 | runGame' :: Game s a -> s -> IO () | 77 | -- | Run the given game, catch any error, run the given finaliser and rethrow the error. |
78 | runGame' game state = runGame game state >> return () | 78 | catchGameErrorFinally :: Game s a -> Game s a -> Game s a |
79 | 79 | catchGameErrorFinally game finally = catchError game $ \err -> finally >> gameError err | |
80 | -- | Run the given game. | 80 | |
81 | runSubGame :: Game s a -> s -> Game t (a,s) | 81 | -- | Run the given game. |
82 | runSubGame game state = lift $ runStateT game state | 82 | runGame :: Game s a -> s -> IO (Either String (a,s)) |
83 | 83 | runGame game state = runErrorT . R.runResourceT . runStateT game $ state | |
84 | -- | Run the given game. | 84 | |
85 | runSubGame' :: Game s a -> s -> Game t () | 85 | -- | Fully run the given sub game, unrolling the entire monad stack. |
86 | runSubGame' game state = runSubGame game state >> return () | 86 | runSubGame :: Game s a -> s -> Game t (a,s) |
87 | 87 | runSubGame game state = gameIO (runGame game state) >>= \result -> case result of | |
88 | -- | Run the given game and return its result. | 88 | Left err -> gameError err |
89 | evalSubGame :: Game s a -> s -> Game t a | 89 | Right x -> return x |
90 | evalSubGame g s = lift $ evalStateT g s | 90 | |
91 | 91 | -- | Run the given game and return its result. | |
92 | -- | Run the given game and return its state. | 92 | evalSubGame :: Game s a -> s -> Game t a |
93 | execSubGame :: Game s a -> s -> Game t s | 93 | evalSubGame g s = runSubGame g s >>= \(a,_) -> return a |
94 | execSubGame g s = lift $ execStateT g s | 94 | |
95 | 95 | -- | Run the given game and return its state. | |
96 | -- | Perform the given IO action in the 'Game' monad. | 96 | execSubGame :: Game s a -> s -> Game t s |
97 | gameIO :: IO a -> Game s a | 97 | execSubGame g s = runSubGame g s >>= \(_,s) -> return s |
98 | gameIO = lift . lift . lift | 98 | |
99 | -- | Perform the given IO action in the 'Game' monad. | ||
100 | gameIO :: IO a -> Game s a | ||
101 | gameIO = lift . lift . lift | ||
diff --git a/Spear/Math/AABB.hs b/Spear/Math/AABB.hs index 681f194..068a619 100644 --- a/Spear/Math/AABB.hs +++ b/Spear/Math/AABB.hs | |||
@@ -1,40 +1,40 @@ | |||
1 | module Spear.Math.AABB | 1 | module Spear.Math.AABB |
2 | ( | 2 | ( |
3 | AABB2(..) | 3 | AABB2(..) |
4 | , AABB3(..) | 4 | , AABB3(..) |
5 | , aabb2 | 5 | , aabb2 |
6 | , aabb3 | 6 | , aabb3 |
7 | , aabb2pt | 7 | , aabb2pt |
8 | , aabb3pt | 8 | , aabb3pt |
9 | ) | 9 | ) |
10 | where | 10 | where |
11 | 11 | ||
12 | import Spear.Math.Vector | 12 | import Spear.Math.Vector |
13 | 13 | ||
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 |
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 |
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 |
24 | aabb2 [] = AABB2 zero2 zero2 | 24 | aabb2 [] = AABB2 zero2 zero2 |
25 | aabb2 (x:xs) = foldl' update (AABB2 x x) xs | 25 | aabb2 (x:xs) = foldl' update (AABB2 x x) xs |
26 | where update (AABB2 pmin pmax) p = AABB2 (min p pmin) (max p pmax) | 26 | where update (AABB2 pmin pmax) p = AABB2 (min p pmin) (max p pmax) |
27 | 27 | ||
28 | -- | Create an AABB from the given points. | 28 | -- | Create an AABB from the given points. |
29 | aabb3 :: [Vector3] -> AABB3 | 29 | aabb3 :: [Vector3] -> AABB3 |
30 | aabb3 [] = AABB3 zero3 zero3 | 30 | aabb3 [] = AABB3 zero3 zero3 |
31 | aabb3 (x:xs) = foldl' update (AABB3 x x) xs | 31 | aabb3 (x:xs) = foldl' update (AABB3 x x) xs |
32 | where update (AABB3 pmin pmax) p = AABB3 (min p pmin) (max p pmax) | 32 | where update (AABB3 pmin pmax) p = AABB3 (min p pmin) (max p pmax) |
33 | 33 | ||
34 | -- | Return 'True' if the given AABB contains the given point, 'False' otherwise. | 34 | -- | Return 'True' if the given AABB contains the given point, 'False' otherwise. |
35 | aabb2pt :: AABB2 -> Vector2 -> Bool | 35 | aabb2pt :: AABB2 -> Vector2 -> Bool |
36 | aabb2pt (AABB2 pmin pmax) v = v >= pmin && v <= pmax | 36 | aabb2pt (AABB2 pmin pmax) v = v >= pmin && v <= pmax |
37 | 37 | ||
38 | -- | Return 'True' if the given AABB contains the given point, 'False' otherwise. | 38 | -- | Return 'True' if the given AABB contains the given point, 'False' otherwise. |
39 | aabb3pt :: AABB3 -> Vector3 -> Bool | 39 | aabb3pt :: AABB3 -> Vector3 -> Bool |
40 | aabb3pt (AABB3 pmin pmax) v = v >= pmin && v <= pmax | 40 | aabb3pt (AABB3 pmin pmax) v = v >= pmin && v <= pmax |
diff --git a/Spear/Math/Camera.hs b/Spear/Math/Camera.hs index e7062ab..220c435 100644 --- a/Spear/Math/Camera.hs +++ b/Spear/Math/Camera.hs | |||
@@ -1,75 +1,75 @@ | |||
1 | module Spear.Math.Camera | 1 | module Spear.Math.Camera |
2 | ( | 2 | ( |
3 | Camera | 3 | Camera |
4 | , Fovy | 4 | , Fovy |
5 | , Aspect | 5 | , Aspect |
6 | , Near | 6 | , Near |
7 | , Far | 7 | , Far |
8 | , Left | 8 | , Left |
9 | , Right | 9 | , Right |
10 | , Bottom | 10 | , Bottom |
11 | , Top | 11 | , Top |
12 | , projection | 12 | , projection |
13 | , perspective | 13 | , perspective |
14 | , ortho | 14 | , ortho |
15 | ) | 15 | ) |
16 | where | 16 | where |
17 | 17 | ||
18 | import qualified Spear.Math.Matrix4 as M | 18 | import qualified Spear.Math.Matrix4 as M |
19 | import Spear.Math.Spatial3 | 19 | import Spear.Math.Spatial3 |
20 | import Spear.Math.Vector | 20 | import Spear.Math.Vector |
21 | 21 | ||
22 | data Camera = Camera | 22 | data Camera = Camera |
23 | { projection :: M.Matrix4 -- ^ Get the camera's projection. | 23 | { projection :: M.Matrix4 -- ^ Get the camera's projection. |
24 | , spatial :: Obj3 | 24 | , spatial :: Obj3 |
25 | } | 25 | } |
26 | 26 | ||
27 | instance Spatial3 Camera where | 27 | instance Spatial3 Camera where |
28 | getObj3 = spatial | 28 | getObj3 = spatial |
29 | setObj3 cam o = cam { spatial = o } | 29 | setObj3 cam o = cam { spatial = o } |
30 | 30 | ||
31 | type Fovy = Float | 31 | type Fovy = Float |
32 | type Aspect = Float | 32 | type Aspect = Float |
33 | type Near = Float | 33 | type Near = Float |
34 | type Far = Float | 34 | type Far = Float |
35 | type Left = Float | 35 | type Left = Float |
36 | type Right = Float | 36 | type Right = Float |
37 | type Bottom = Float | 37 | type Bottom = Float |
38 | type Top = Float | 38 | type Top = Float |
39 | 39 | ||
40 | -- | Build a perspective camera. | 40 | -- | Build a perspective camera. |
41 | perspective :: Fovy -- ^ Fovy - Vertical field of view angle in degrees. | 41 | perspective :: Fovy -- ^ Fovy - Vertical field of view angle in degrees. |
42 | -> Aspect -- ^ Aspect ratio. | 42 | -> Aspect -- ^ Aspect ratio. |
43 | -> Near -- ^ Near clip. | 43 | -> Near -- ^ Near clip. |
44 | -> Far -- ^ Far clip. | 44 | -> Far -- ^ Far clip. |
45 | -> Right3 -- ^ Right vector. | 45 | -> Right3 -- ^ Right vector. |
46 | -> Up3 -- ^ Up vector. | 46 | -> Up3 -- ^ Up vector. |
47 | -> Forward3 -- ^ Forward vector. | 47 | -> Forward3 -- ^ Forward vector. |
48 | -> Position3 -- ^ Position vector. | 48 | -> Position3 -- ^ Position vector. |
49 | -> Camera | 49 | -> Camera |
50 | 50 | ||
51 | perspective fovy r n f right up fwd pos = | 51 | perspective fovy r n f right up fwd pos = |
52 | Camera | 52 | Camera |
53 | { projection = M.perspective fovy r n f | 53 | { projection = M.perspective fovy r n f |
54 | , spatial = fromVectors right up fwd pos | 54 | , spatial = fromVectors right up fwd pos |
55 | } | 55 | } |
56 | 56 | ||
57 | 57 | ||
58 | -- | Build an orthogonal camera. | 58 | -- | Build an orthogonal camera. |
59 | ortho :: Left -- ^ Left. | 59 | ortho :: Left -- ^ Left. |
60 | -> Right -- ^ Right. | 60 | -> Right -- ^ Right. |
61 | -> Bottom -- ^ Bottom. | 61 | -> Bottom -- ^ Bottom. |
62 | -> Top -- ^ Top. | 62 | -> Top -- ^ Top. |
63 | -> Near -- ^ Near clip. | 63 | -> Near -- ^ Near clip. |
64 | -> Far -- ^ Far clip. | 64 | -> Far -- ^ Far clip. |
65 | -> Right3 -- ^ Right vector. | 65 | -> Right3 -- ^ Right vector. |
66 | -> Up3 -- ^ Up vector. | 66 | -> Up3 -- ^ Up vector. |
67 | -> Forward3 -- ^ Forward vector. | 67 | -> Forward3 -- ^ Forward vector. |
68 | -> Position3 -- ^ Position vector. | 68 | -> Position3 -- ^ Position vector. |
69 | -> Camera | 69 | -> Camera |
70 | 70 | ||
71 | ortho l r b t n f right up fwd pos = | 71 | ortho l r b t n f right up fwd pos = |
72 | Camera | 72 | Camera |
73 | { projection = M.ortho l r b t n f | 73 | { projection = M.ortho l r b t n f |
74 | , spatial = fromVectors right up fwd pos | 74 | , spatial = fromVectors right up fwd pos |
75 | } | 75 | } |
diff --git a/Spear/Math/Circle.hs b/Spear/Math/Circle.hs index 33b60ab..e4a9bb6 100644 --- a/Spear/Math/Circle.hs +++ b/Spear/Math/Circle.hs | |||
@@ -1,26 +1,26 @@ | |||
1 | module Spear.Math.Circle | 1 | module Spear.Math.Circle |
2 | where | 2 | where |
3 | 3 | ||
4 | import Spear.Math.Vector | 4 | import Spear.Math.Vector |
5 | 5 | ||
6 | import Data.List (foldl') | 6 | import Data.List (foldl') |
7 | 7 | ||
8 | -- | A circle in 2D space. | 8 | -- | A circle in 2D space. |
9 | data Circle = Circle | 9 | data Circle = Circle |
10 | { center :: {-# UNPACK #-} !Vector2 | 10 | { center :: {-# UNPACK #-} !Vector2 |
11 | , radius :: {-# UNPACK #-} !Float | 11 | , radius :: {-# UNPACK #-} !Float |
12 | } | 12 | } |
13 | 13 | ||
14 | -- | Create a circle from the given points. | 14 | -- | Create a circle from the given points. |
15 | circle :: [Vector2] -> Circle | 15 | circle :: [Vector2] -> Circle |
16 | circle [] = Circle zero2 0 | 16 | circle [] = Circle zero2 0 |
17 | circle (x:xs) = Circle c r | 17 | circle (x:xs) = Circle c r |
18 | where | 18 | where |
19 | c = pmin + (pmax-pmin)/2 | 19 | c = pmin + (pmax-pmin)/2 |
20 | r = norm $ pmax - c | 20 | r = norm $ pmax - c |
21 | (pmin,pmax) = foldl' update (x,x) xs | 21 | (pmin,pmax) = foldl' update (x,x) xs |
22 | update (pmin,pmax) p = (min p pmin, max p pmax) | 22 | update (pmin,pmax) p = (min p pmin, max p pmax) |
23 | 23 | ||
24 | -- | Return 'True' if the given circle contains the given point, 'False' otherwise. | 24 | -- | Return 'True' if the given circle contains the given point, 'False' otherwise. |
25 | circlept :: Circle -> Vector2 -> Bool | 25 | circlept :: Circle -> Vector2 -> Bool |
26 | circlept (Circle c r) p = r*r >= normSq (p - c) | 26 | circlept (Circle c r) p = r*r >= normSq (p - c) |
diff --git a/Spear/Math/Collision.hs b/Spear/Math/Collision.hs index 47cc5fd..a69ea7a 100644 --- a/Spear/Math/Collision.hs +++ b/Spear/Math/Collision.hs | |||
@@ -1,242 +1,242 @@ | |||
1 | module Spear.Math.Collision | 1 | module Spear.Math.Collision |
2 | ( | 2 | ( |
3 | CollisionType(..) | 3 | CollisionType(..) |
4 | -- * 2D Collision | 4 | -- * 2D Collision |
5 | , Collisionable2(..) | 5 | , Collisionable2(..) |
6 | , Collisioner2(..) | 6 | , Collisioner2(..) |
7 | -- ** Construction | 7 | -- ** Construction |
8 | , aabb2Collisioner | 8 | , aabb2Collisioner |
9 | , circleCollisioner | 9 | , circleCollisioner |
10 | , mkCols | 10 | , mkCols |
11 | -- ** Collision test | 11 | -- ** Collision test |
12 | , collide | 12 | , collide |
13 | -- ** Manipulation | 13 | -- ** Manipulation |
14 | , move | 14 | , move |
15 | -- ** Helpers | 15 | -- ** Helpers |
16 | , buildAABB2 | 16 | , buildAABB2 |
17 | , aabb2FromCircle | 17 | , aabb2FromCircle |
18 | , circleFromAABB2 | 18 | , circleFromAABB2 |
19 | -- * 3D Collision | 19 | -- * 3D Collision |
20 | , Collisionable3(..) | 20 | , Collisionable3(..) |
21 | -- ** Helpers | 21 | -- ** Helpers |
22 | , aabb3FromSphere | 22 | , aabb3FromSphere |
23 | ) | 23 | ) |
24 | where | 24 | where |
25 | 25 | ||
26 | import Spear.Assets.Model | 26 | import Spear.Assets.Model |
27 | import Spear.Math.AABB | 27 | import Spear.Math.AABB |
28 | import Spear.Math.Circle | 28 | import Spear.Math.Circle |
29 | import qualified Spear.Math.Matrix4 as M4 | 29 | import qualified Spear.Math.Matrix4 as M4 |
30 | import Spear.Math.Plane | 30 | import Spear.Math.Plane |
31 | import Spear.Math.Sphere | 31 | import Spear.Math.Sphere |
32 | import Spear.Math.Vector | 32 | import Spear.Math.Vector |
33 | 33 | ||
34 | import Data.List (foldl') | 34 | import Data.List (foldl') |
35 | 35 | ||
36 | data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy | 36 | data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy |
37 | deriving (Eq, Show) | 37 | deriving (Eq, Show) |
38 | 38 | ||
39 | -- 2D collision | 39 | -- 2D collision |
40 | 40 | ||
41 | class Collisionable2 a where | 41 | class Collisionable2 a where |
42 | 42 | ||
43 | -- | Collide the object with an AABB. | 43 | -- | Collide the object with an AABB. |
44 | collideAABB2 :: AABB2 -> a -> CollisionType | 44 | collideAABB2 :: AABB2 -> a -> CollisionType |
45 | 45 | ||
46 | -- | Collide the object with a circle. | 46 | -- | Collide the object with a circle. |
47 | collideCircle :: Circle -> a -> CollisionType | 47 | collideCircle :: Circle -> a -> CollisionType |
48 | 48 | ||
49 | instance Collisionable2 AABB2 where | 49 | instance Collisionable2 AABB2 where |
50 | 50 | ||
51 | collideAABB2 box1@(AABB2 min1 max1) box2@(AABB2 min2 max2) | 51 | collideAABB2 box1@(AABB2 min1 max1) box2@(AABB2 min2 max2) |
52 | | (x max1) < (x min2) = NoCollision | 52 | | (x max1) < (x min2) = NoCollision |
53 | | (x min1) > (x max2) = NoCollision | 53 | | (x min1) > (x max2) = NoCollision |
54 | | (y max1) < (y min2) = NoCollision | 54 | | (y max1) < (y min2) = NoCollision |
55 | | (y min1) > (y max2) = NoCollision | 55 | | (y min1) > (y max2) = NoCollision |
56 | | box1 `aabb2pt` min2 && box1 `aabb2pt` max2 = FullyContains | 56 | | box1 `aabb2pt` min2 && box1 `aabb2pt` max2 = FullyContains |
57 | | box2 `aabb2pt` min1 && box2 `aabb2pt` max1 = FullyContainedBy | 57 | | box2 `aabb2pt` min1 && box2 `aabb2pt` max1 = FullyContainedBy |
58 | | otherwise = Collision | 58 | | otherwise = Collision |
59 | 59 | ||
60 | collideCircle circle@(Circle c r) aabb@(AABB2 min max) | 60 | collideCircle circle@(Circle c r) aabb@(AABB2 min max) |
61 | | test == FullyContains || test == FullyContainedBy = test | 61 | | test == FullyContains || test == FullyContainedBy = test |
62 | | normSq (c - boxC) > (l + r)^2 = NoCollision | 62 | | normSq (c - boxC) > (l + r)^2 = NoCollision |
63 | | otherwise = Collision | 63 | | otherwise = Collision |
64 | where | 64 | where |
65 | test = collideAABB2 aabb $ aabb2FromCircle circle | 65 | test = collideAABB2 aabb $ aabb2FromCircle circle |
66 | boxC = min + (max-min)/2 | 66 | boxC = min + (max-min)/2 |
67 | l = norm $ min + (vec2 (x boxC) (y min)) - min | 67 | l = norm $ min + (vec2 (x boxC) (y min)) - min |
68 | 68 | ||
69 | instance Collisionable2 Circle where | 69 | instance Collisionable2 Circle where |
70 | 70 | ||
71 | collideAABB2 box circle = case collideCircle circle box of | 71 | collideAABB2 box circle = case collideCircle circle box of |
72 | FullyContains -> FullyContainedBy | 72 | FullyContains -> FullyContainedBy |
73 | FullyContainedBy -> FullyContains | 73 | FullyContainedBy -> FullyContains |
74 | x -> x | 74 | x -> x |
75 | 75 | ||
76 | collideCircle s1@(Circle c1 r1) s2@(Circle c2 r2) | 76 | collideCircle s1@(Circle c1 r1) s2@(Circle c2 r2) |
77 | | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy | 77 | | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy |
78 | | distance_centers <= sum_radii = Collision | 78 | | distance_centers <= sum_radii = Collision |
79 | | otherwise = NoCollision | 79 | | otherwise = NoCollision |
80 | where | 80 | where |
81 | distance_centers = normSq $ c1 - c2 | 81 | distance_centers = normSq $ c1 - c2 |
82 | sum_radii = (r1 + r2)^2 | 82 | sum_radii = (r1 + r2)^2 |
83 | sub_radii = (r1 - r2)^2 | 83 | sub_radii = (r1 - r2)^2 |
84 | 84 | ||
85 | instance Collisionable2 Collisioner2 where | 85 | instance Collisionable2 Collisioner2 where |
86 | 86 | ||
87 | collideAABB2 box (AABB2Col self) = collideAABB2 box self | 87 | collideAABB2 box (AABB2Col self) = collideAABB2 box self |
88 | collideAABB2 box (CircleCol self) = collideAABB2 box self | 88 | collideAABB2 box (CircleCol self) = collideAABB2 box self |
89 | 89 | ||
90 | collideCircle circle (AABB2Col self) = collideCircle circle self | 90 | collideCircle circle (AABB2Col self) = collideCircle circle self |
91 | collideCircle circle (CircleCol self) = collideCircle circle self | 91 | collideCircle circle (CircleCol self) = collideCircle circle self |
92 | 92 | ||
93 | aabbPoints :: AABB2 -> [Vector2] | 93 | aabbPoints :: AABB2 -> [Vector2] |
94 | aabbPoints (AABB2 min max) = [p1,p2,p3,p4,p5,p6,p7,p8] | 94 | aabbPoints (AABB2 min max) = [p1,p2,p3,p4,p5,p6,p7,p8] |
95 | where | 95 | where |
96 | p1 = vec2 (x min) (y min) | 96 | p1 = vec2 (x min) (y min) |
97 | p2 = vec2 (x min) (y min) | 97 | p2 = vec2 (x min) (y min) |
98 | p3 = vec2 (x min) (y max) | 98 | p3 = vec2 (x min) (y max) |
99 | p4 = vec2 (x min) (y max) | 99 | p4 = vec2 (x min) (y max) |
100 | p5 = vec2 (x max) (y min) | 100 | p5 = vec2 (x max) (y min) |
101 | p6 = vec2 (x max) (y min) | 101 | p6 = vec2 (x max) (y min) |
102 | p7 = vec2 (x max) (y max) | 102 | p7 = vec2 (x max) (y max) |
103 | p8 = vec2 (x max) (y max) | 103 | p8 = vec2 (x max) (y max) |
104 | 104 | ||
105 | 105 | ||
106 | -- | A collisioner component. | 106 | -- | A collisioner component. |
107 | data Collisioner2 | 107 | data Collisioner2 |
108 | -- | An axis-aligned bounding box. | 108 | -- | An axis-aligned bounding box. |
109 | = AABB2Col {-# UNPACK #-} !AABB2 | 109 | = AABB2Col {-# UNPACK #-} !AABB2 |
110 | -- | A bounding circle. | 110 | -- | A bounding circle. |
111 | | CircleCol {-# UNPACK #-} !Circle | 111 | | CircleCol {-# UNPACK #-} !Circle |
112 | 112 | ||
113 | 113 | ||
114 | -- | Create a collisioner from the specified box. | 114 | -- | Create a collisioner from the specified box. |
115 | aabb2Collisioner :: AABB2 -> Collisioner2 | 115 | aabb2Collisioner :: AABB2 -> Collisioner2 |
116 | aabb2Collisioner = AABB2Col | 116 | aabb2Collisioner = AABB2Col |
117 | 117 | ||
118 | -- | Create a collisioner from the specified circle. | 118 | -- | Create a collisioner from the specified circle. |
119 | circleCollisioner :: Circle -> Collisioner2 | 119 | circleCollisioner :: Circle -> Collisioner2 |
120 | circleCollisioner = CircleCol | 120 | circleCollisioner = CircleCol |
121 | 121 | ||
122 | -- | Compute AABB collisioners in view space from the given AABB. | 122 | -- | Compute AABB collisioners in view space from the given AABB. |
123 | mkCols :: M4.Matrix4 -- ^ Modelview matrix | 123 | mkCols :: M4.Matrix4 -- ^ Modelview matrix |
124 | -> Box | 124 | -> Box |
125 | -> [Collisioner2] | 125 | -> [Collisioner2] |
126 | mkCols modelview (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = | 126 | mkCols modelview (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = |
127 | let | 127 | let |
128 | toVec2 v = vec2 (x v) (y v) | 128 | toVec2 v = vec2 (x v) (y v) |
129 | p1 = toVec2 $ modelview `M4.mulp` vec3 xmin ymin zmax | 129 | p1 = toVec2 $ modelview `M4.mulp` vec3 xmin ymin zmax |
130 | p2 = toVec2 $ modelview `M4.mulp` vec3 xmax ymin zmin | 130 | p2 = toVec2 $ modelview `M4.mulp` vec3 xmax ymin zmin |
131 | p3 = toVec2 $ modelview `M4.mulp` vec3 xmax ymax zmin | 131 | p3 = toVec2 $ modelview `M4.mulp` vec3 xmax ymax zmin |
132 | col1 = AABB2Col $ AABB2 p1 p2 | 132 | col1 = AABB2Col $ AABB2 p1 p2 |
133 | col2 = AABB2Col $ AABB2 p1 p3 | 133 | col2 = AABB2Col $ AABB2 p1 p3 |
134 | in | 134 | in |
135 | [col1, col2] | 135 | [col1, col2] |
136 | 136 | ||
137 | -- | Create the minimal AABB fully containing the specified collisioners. | 137 | -- | Create the minimal AABB fully containing the specified collisioners. |
138 | buildAABB2 :: [Collisioner2] -> AABB2 | 138 | buildAABB2 :: [Collisioner2] -> AABB2 |
139 | buildAABB2 cols = aabb2 $ generatePoints cols | 139 | buildAABB2 cols = aabb2 $ generatePoints cols |
140 | 140 | ||
141 | -- | Create the minimal box fully containing the specified circle. | 141 | -- | Create the minimal box fully containing the specified circle. |
142 | aabb2FromCircle :: Circle -> AABB2 | 142 | aabb2FromCircle :: Circle -> AABB2 |
143 | aabb2FromCircle (Circle c r) = AABB2 bot top | 143 | aabb2FromCircle (Circle c r) = AABB2 bot top |
144 | where | 144 | where |
145 | bot = c - (vec2 r r) | 145 | bot = c - (vec2 r r) |
146 | top = c + (vec2 r r) | 146 | top = c + (vec2 r r) |
147 | 147 | ||
148 | -- | Create the minimal circle fully containing the specified box. | 148 | -- | Create the minimal circle fully containing the specified box. |
149 | circleFromAABB2 :: AABB2 -> Circle | 149 | circleFromAABB2 :: AABB2 -> Circle |
150 | circleFromAABB2 (AABB2 min max) = Circle c r | 150 | circleFromAABB2 (AABB2 min max) = Circle c r |
151 | where | 151 | where |
152 | c = scale 0.5 (min + max) | 152 | c = scale 0.5 (min + max) |
153 | r = norm . scale 0.5 $ max - min | 153 | r = norm . scale 0.5 $ max - min |
154 | 154 | ||
155 | generatePoints :: [Collisioner2] -> [Vector2] | 155 | generatePoints :: [Collisioner2] -> [Vector2] |
156 | generatePoints = foldl' generate [] | 156 | generatePoints = foldl' generate [] |
157 | where | 157 | where |
158 | generate acc (AABB2Col (AABB2 pmin pmax)) = p1:p2:p3:p4:p5:p6:p7:p8:acc | 158 | generate acc (AABB2Col (AABB2 pmin pmax)) = p1:p2:p3:p4:p5:p6:p7:p8:acc |
159 | where | 159 | where |
160 | p1 = vec2 (x pmin) (y pmin) | 160 | p1 = vec2 (x pmin) (y pmin) |
161 | p2 = vec2 (x pmin) (y pmin) | 161 | p2 = vec2 (x pmin) (y pmin) |
162 | p3 = vec2 (x pmin) (y pmax) | 162 | p3 = vec2 (x pmin) (y pmax) |
163 | p4 = vec2 (x pmin) (y pmax) | 163 | p4 = vec2 (x pmin) (y pmax) |
164 | p5 = vec2 (x pmax) (y pmin) | 164 | p5 = vec2 (x pmax) (y pmin) |
165 | p6 = vec2 (x pmax) (y pmin) | 165 | p6 = vec2 (x pmax) (y pmin) |
166 | p7 = vec2 (x pmax) (y pmax) | 166 | p7 = vec2 (x pmax) (y pmax) |
167 | p8 = vec2 (x pmax) (y pmax) | 167 | p8 = vec2 (x pmax) (y pmax) |
168 | 168 | ||
169 | generate acc (CircleCol (Circle c r)) = p1:p2:p3:p4:acc | 169 | generate acc (CircleCol (Circle c r)) = p1:p2:p3:p4:acc |
170 | where | 170 | where |
171 | p1 = c + unitx2 * (vec2 r r) | 171 | p1 = c + unitx2 * (vec2 r r) |
172 | p2 = c - unitx2 * (vec2 r r) | 172 | p2 = c - unitx2 * (vec2 r r) |
173 | p3 = c + unity2 * (vec2 r r) | 173 | p3 = c + unity2 * (vec2 r r) |
174 | p4 = c - unity2 * (vec2 r r) | 174 | p4 = c - unity2 * (vec2 r r) |
175 | 175 | ||
176 | -- | Collide the given collisioners. | 176 | -- | Collide the given collisioners. |
177 | collide :: Collisioner2 -> Collisioner2 -> CollisionType | 177 | collide :: Collisioner2 -> Collisioner2 -> CollisionType |
178 | collide (AABB2Col box1) (AABB2Col box2) = collideAABB2 box1 box2 | 178 | collide (AABB2Col box1) (AABB2Col box2) = collideAABB2 box1 box2 |
179 | collide (AABB2Col box) (CircleCol circle) = collideAABB2 box circle | 179 | collide (AABB2Col box) (CircleCol circle) = collideAABB2 box circle |
180 | collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2 | 180 | collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2 |
181 | collide (CircleCol circle) (AABB2Col box) = collideCircle circle box | 181 | collide (CircleCol circle) (AABB2Col box) = collideCircle circle box |
182 | 182 | ||
183 | -- | Move the collisioner. | 183 | -- | Move the collisioner. |
184 | move :: Vector2 -> Collisioner2 -> Collisioner2 | 184 | move :: Vector2 -> Collisioner2 -> Collisioner2 |
185 | move v (AABB2Col (AABB2 min max)) = AABB2Col (AABB2 (min+v) (max+v)) | 185 | move v (AABB2Col (AABB2 min max)) = AABB2Col (AABB2 (min+v) (max+v)) |
186 | move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r) | 186 | move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r) |
187 | 187 | ||
188 | 188 | ||
189 | -- 3D collision | 189 | -- 3D collision |
190 | 190 | ||
191 | class Collisionable3 a where | 191 | class Collisionable3 a where |
192 | 192 | ||
193 | -- | Collide the object with an AABB. | 193 | -- | Collide the object with an AABB. |
194 | collideAABB3 :: AABB3 -> a -> CollisionType | 194 | collideAABB3 :: AABB3 -> a -> CollisionType |
195 | 195 | ||
196 | -- | Collide the object with a sphere. | 196 | -- | Collide the object with a sphere. |
197 | collideSphere :: Sphere -> a -> CollisionType | 197 | collideSphere :: Sphere -> a -> CollisionType |
198 | 198 | ||
199 | instance Collisionable3 AABB3 where | 199 | instance Collisionable3 AABB3 where |
200 | 200 | ||
201 | collideAABB3 box1@(AABB3 min1 max1) box2@(AABB3 min2 max2) | 201 | collideAABB3 box1@(AABB3 min1 max1) box2@(AABB3 min2 max2) |
202 | | (x max1) < (x min2) = NoCollision | 202 | | (x max1) < (x min2) = NoCollision |
203 | | (x min1) > (x max2) = NoCollision | 203 | | (x min1) > (x max2) = NoCollision |
204 | | (y max1) < (y min2) = NoCollision | 204 | | (y max1) < (y min2) = NoCollision |
205 | | (y min1) > (y max2) = NoCollision | 205 | | (y min1) > (y max2) = NoCollision |
206 | | box1 `aabb3pt` min2 && box1 `aabb3pt` max2 = FullyContains | 206 | | box1 `aabb3pt` min2 && box1 `aabb3pt` max2 = FullyContains |
207 | | box2 `aabb3pt` min1 && box2 `aabb3pt` max1 = FullyContainedBy | 207 | | box2 `aabb3pt` min1 && box2 `aabb3pt` max1 = FullyContainedBy |
208 | | otherwise = Collision | 208 | | otherwise = Collision |
209 | 209 | ||
210 | collideSphere sphere@(Sphere c r) aabb@(AABB3 min max) | 210 | collideSphere sphere@(Sphere c r) aabb@(AABB3 min max) |
211 | | test == FullyContains || test == FullyContainedBy = test | 211 | | test == FullyContains || test == FullyContainedBy = test |
212 | | normSq (c - boxC) > (l + r)^2 = NoCollision | 212 | | normSq (c - boxC) > (l + r)^2 = NoCollision |
213 | | otherwise = Collision | 213 | | otherwise = Collision |
214 | where | 214 | where |
215 | test = collideAABB3 aabb $ aabb3FromSphere sphere | 215 | test = collideAABB3 aabb $ aabb3FromSphere sphere |
216 | boxC = min + v | 216 | boxC = min + v |
217 | l = norm v | 217 | l = norm v |
218 | v = (max-min)/2 | 218 | v = (max-min)/2 |
219 | 219 | ||
220 | instance Collisionable3 Sphere where | 220 | instance Collisionable3 Sphere where |
221 | 221 | ||
222 | collideAABB3 box sphere = case collideSphere sphere box of | 222 | collideAABB3 box sphere = case collideSphere sphere box of |
223 | FullyContains -> FullyContainedBy | 223 | FullyContains -> FullyContainedBy |
224 | FullyContainedBy -> FullyContains | 224 | FullyContainedBy -> FullyContains |
225 | x -> x | 225 | x -> x |
226 | 226 | ||
227 | collideSphere s1@(Sphere c1 r1) s2@(Sphere c2 r2) | 227 | collideSphere s1@(Sphere c1 r1) s2@(Sphere c2 r2) |
228 | | distance_centers <= sub_radii = | 228 | | distance_centers <= sub_radii = |
229 | if (r1 > r2) then FullyContains else FullyContainedBy | 229 | if (r1 > r2) then FullyContains else FullyContainedBy |
230 | | distance_centers <= sum_radii = Collision | 230 | | distance_centers <= sum_radii = Collision |
231 | | otherwise = NoCollision | 231 | | otherwise = NoCollision |
232 | where | 232 | where |
233 | distance_centers = normSq $ c1 - c2 | 233 | distance_centers = normSq $ c1 - c2 |
234 | sum_radii = (r1 + r2)^2 | 234 | sum_radii = (r1 + r2)^2 |
235 | sub_radii = (r1 - r2)^2 | 235 | sub_radii = (r1 - r2)^2 |
236 | 236 | ||
237 | -- | Create the minimal box fully containing the specified sphere. | 237 | -- | Create the minimal box fully containing the specified sphere. |
238 | aabb3FromSphere :: Sphere -> AABB3 | 238 | aabb3FromSphere :: Sphere -> AABB3 |
239 | aabb3FromSphere (Sphere c r) = AABB3 bot top | 239 | aabb3FromSphere (Sphere c r) = AABB3 bot top |
240 | where | 240 | where |
241 | bot = c - (vec3 r r r) | 241 | bot = c - (vec3 r r r) |
242 | top = c + (vec3 r r r) \ No newline at end of file | 242 | top = c + (vec3 r r r) \ No newline at end of file |
diff --git a/Spear/Math/Entity.hs b/Spear/Math/Entity.hs index 4fc3d87..4d29a95 100644 --- a/Spear/Math/Entity.hs +++ b/Spear/Math/Entity.hs | |||
@@ -1,33 +1,33 @@ | |||
1 | module Spear.Math.Entity | 1 | module Spear.Math.Entity |
2 | ( | 2 | ( |
3 | Entity(..) | 3 | Entity(..) |
4 | ) | 4 | ) |
5 | where | 5 | where |
6 | 6 | ||
7 | 7 | ||
8 | import qualified Spear.Math.Matrix3 as M | 8 | import qualified Spear.Math.Matrix3 as M |
9 | import qualified Spear.Math.Spatial2 as S | 9 | import qualified Spear.Math.Spatial2 as S |
10 | import qualified Spear.Math.Vector as V | 10 | import qualified Spear.Math.Vector as V |
11 | 11 | ||
12 | 12 | ||
13 | -- | An entity in 2D space. | 13 | -- | An entity in 2D space. |
14 | newtype Entity = Entity { transform :: M.Matrix3 } | 14 | newtype Entity = Entity { transform :: M.Matrix3 } |
15 | 15 | ||
16 | 16 | ||
17 | instance S.Spatial2 Entity where | 17 | instance S.Spatial2 Entity where |
18 | move v ent = ent { transform = M.translv v * transform ent } | 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 } | 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 } | 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 } | 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 } | 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 } | 23 | rotate a ent = ent { transform = transform ent * M.rot a } |
24 | setRotation a ent = | 24 | setRotation a ent = |
25 | let t = transform ent | 25 | let t = transform ent |
26 | in ent { transform = M.translation t * M.rot a } | 26 | in ent { transform = M.translation t * M.rot a } |
27 | pos = M.position . transform | 27 | pos = M.position . transform |
28 | fwd = M.forward . transform | 28 | fwd = M.forward . transform |
29 | up = M.up . transform | 29 | up = M.up . transform |
30 | right = M.right . transform | 30 | right = M.right . transform |
31 | transform (Entity t) = t | 31 | transform (Entity t) = t |
32 | setTransform t (Entity _) = Entity t | 32 | setTransform t (Entity _) = Entity t |
33 | setPos pos (Entity t) = Entity $ M.transform (M.right t) (M.forward t) pos | 33 | setPos pos (Entity t) = Entity $ M.transform (M.right t) (M.forward t) pos |
diff --git a/Spear/Math/Frustum.hs b/Spear/Math/Frustum.hs index b23882a..b9c00df 100644 --- a/Spear/Math/Frustum.hs +++ b/Spear/Math/Frustum.hs | |||
@@ -1,28 +1,28 @@ | |||
1 | module Spear.Math.Frustum | 1 | module Spear.Math.Frustum |
2 | where | 2 | where |
3 | 3 | ||
4 | import Spear.Math.Plane | 4 | import Spear.Math.Plane |
5 | 5 | ||
6 | data Frustum = Frustum | 6 | data Frustum = Frustum |
7 | { n :: {-# UNPACK #-} !Plane | 7 | { n :: {-# UNPACK #-} !Plane |
8 | , f :: {-# UNPACK #-} !Plane | 8 | , f :: {-# UNPACK #-} !Plane |
9 | , l :: {-# UNPACK #-} !Plane | 9 | , l :: {-# UNPACK #-} !Plane |
10 | , r :: {-# UNPACK #-} !Plane | 10 | , r :: {-# UNPACK #-} !Plane |
11 | , t :: {-# UNPACK #-} !Plane | 11 | , t :: {-# UNPACK #-} !Plane |
12 | , b :: {-# UNPACK #-} !Plane | 12 | , b :: {-# UNPACK #-} !Plane |
13 | } deriving Show | 13 | } deriving Show |
14 | 14 | ||
15 | -- | Construct a frustum. | 15 | -- | Construct a frustum. |
16 | frustum | 16 | frustum |
17 | :: Plane -- ^ Near | 17 | :: Plane -- ^ Near |
18 | -> Plane -- ^ Far | 18 | -> Plane -- ^ Far |
19 | -> Plane -- ^ Left | 19 | -> Plane -- ^ Left |
20 | -> Plane -- ^ Right | 20 | -> Plane -- ^ Right |
21 | -> Plane -- ^ Top | 21 | -> Plane -- ^ Top |
22 | -> Plane -- ^ Bottom | 22 | -> Plane -- ^ Bottom |
23 | -> Frustum | 23 | -> Frustum |
24 | frustum = Frustum | 24 | frustum = Frustum |
25 | 25 | ||
26 | -- | Construct a frustum. | 26 | -- | Construct a frustum. |
27 | fromList :: [Plane] -> Frustum | 27 | fromList :: [Plane] -> Frustum |
28 | fromList (n:f:l:r:t:b:_) = Frustum n f l r t b | 28 | fromList (n:f:l:r:t:b:_) = Frustum n f l r t b |
diff --git a/Spear/Math/Matrix3.hs b/Spear/Math/Matrix3.hs index 497cb4e..7526827 100644 --- a/Spear/Math/Matrix3.hs +++ b/Spear/Math/Matrix3.hs | |||
@@ -1,335 +1,335 @@ | |||
1 | module Spear.Math.Matrix3 | 1 | module Spear.Math.Matrix3 |
2 | ( | 2 | ( |
3 | Matrix3 | 3 | Matrix3 |
4 | -- * Accessors | 4 | -- * Accessors |
5 | , m00, m01, m02 | 5 | , m00, m01, m02 |
6 | , m10, m11, m12 | 6 | , m10, m11, m12 |
7 | , m20, m21, m22 | 7 | , m20, m21, m22 |
8 | , col0, col1, col2 | 8 | , col0, col1, col2 |
9 | , row0, row1, row2 | 9 | , row0, row1, row2 |
10 | , right, up, forward, position | 10 | , right, up, forward, position |
11 | -- * Construction | 11 | -- * Construction |
12 | , mat3 | 12 | , mat3 |
13 | , mat3fromVec | 13 | , mat3fromVec |
14 | , transform | 14 | , transform |
15 | , translation | 15 | , translation |
16 | , rotation | 16 | , rotation |
17 | , Spear.Math.Matrix3.id | 17 | , Spear.Math.Matrix3.id |
18 | -- * Transformations | 18 | -- * Transformations |
19 | -- ** Translation | 19 | -- ** Translation |
20 | , transl | 20 | , transl |
21 | , translv | 21 | , translv |
22 | -- ** Rotation | 22 | -- ** Rotation |
23 | , rot | 23 | , rot |
24 | -- ** Scale | 24 | -- ** Scale |
25 | , Spear.Math.Matrix3.scale | 25 | , Spear.Math.Matrix3.scale |
26 | , scalev | 26 | , scalev |
27 | -- ** Reflection | 27 | -- ** Reflection |
28 | , reflectX | 28 | , reflectX |
29 | , reflectY | 29 | , reflectY |
30 | , reflectZ | 30 | , reflectZ |
31 | -- * Operations | 31 | -- * Operations |
32 | , transpose | 32 | , transpose |
33 | , mulp | 33 | , mulp |
34 | , muld | 34 | , muld |
35 | , mul | 35 | , mul |
36 | , inverseTransform | 36 | , inverseTransform |
37 | , Spear.Math.Matrix3.zipWith | 37 | , Spear.Math.Matrix3.zipWith |
38 | , Spear.Math.Matrix3.map | 38 | , Spear.Math.Matrix3.map |
39 | ) | 39 | ) |
40 | where | 40 | where |
41 | 41 | ||
42 | 42 | ||
43 | import Spear.Math.Vector | 43 | import Spear.Math.Vector |
44 | 44 | ||
45 | import Foreign.Storable | 45 | import Foreign.Storable |
46 | 46 | ||
47 | 47 | ||
48 | -- | Represents a 3x3 column major matrix. | 48 | -- | Represents a 3x3 column major matrix. |
49 | data Matrix3 = Matrix3 | 49 | data Matrix3 = Matrix3 |
50 | { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float | 50 | { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float |
51 | , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float | 51 | , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float |
52 | , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float | 52 | , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float |
53 | } | 53 | } |
54 | 54 | ||
55 | 55 | ||
56 | instance Show Matrix3 where | 56 | instance Show Matrix3 where |
57 | 57 | ||
58 | show (Matrix3 m00 m10 m20 m01 m11 m21 m02 m12 m22) = | 58 | show (Matrix3 m00 m10 m20 m01 m11 m21 m02 m12 m22) = |
59 | show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ "\n" ++ | 59 | show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ "\n" ++ |
60 | show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ "\n" ++ | 60 | show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ "\n" ++ |
61 | show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ "\n" | 61 | show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ "\n" |
62 | where | 62 | where |
63 | show' f = if abs f < 0.0000001 then "0" else show f | 63 | show' f = if abs f < 0.0000001 then "0" else show f |
64 | 64 | ||
65 | 65 | ||
66 | instance Num Matrix3 where | 66 | instance Num Matrix3 where |
67 | (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) | 67 | (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) |
68 | + (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) | 68 | + (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) |
69 | = Matrix3 (a00 + b00) (a01 + b01) (a02 + b02) | 69 | = Matrix3 (a00 + b00) (a01 + b01) (a02 + b02) |
70 | (a03 + b03) (a04 + b04) (a05 + b05) | 70 | (a03 + b03) (a04 + b04) (a05 + b05) |
71 | (a06 + b06) (a07 + b07) (a08 + b08) | 71 | (a06 + b06) (a07 + b07) (a08 + b08) |
72 | 72 | ||
73 | (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) | 73 | (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) |
74 | - (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) | 74 | - (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) |
75 | = Matrix3 (a00 - b00) (a01 - b01) (a02 - b02) | 75 | = Matrix3 (a00 - b00) (a01 - b01) (a02 - b02) |
76 | (a03 - b03) (a04 - b04) (a05 - b05) | 76 | (a03 - b03) (a04 - b04) (a05 - b05) |
77 | (a06 - b06) (a07 - b07) (a08 - b08) | 77 | (a06 - b06) (a07 - b07) (a08 - b08) |
78 | 78 | ||
79 | (Matrix3 a00 a10 a20 a01 a11 a21 a02 a12 a22) | 79 | (Matrix3 a00 a10 a20 a01 a11 a21 a02 a12 a22) |
80 | * (Matrix3 b00 b10 b20 b01 b11 b21 b02 b12 b22) | 80 | * (Matrix3 b00 b10 b20 b01 b11 b21 b02 b12 b22) |
81 | = Matrix3 (a00 * b00 + a10 * b01 + a20 * b02) | 81 | = Matrix3 (a00 * b00 + a10 * b01 + a20 * b02) |
82 | (a00 * b10 + a10 * b11 + a20 * b12) | 82 | (a00 * b10 + a10 * b11 + a20 * b12) |
83 | (a00 * b20 + a10 * b21 + a20 * b22) | 83 | (a00 * b20 + a10 * b21 + a20 * b22) |
84 | 84 | ||
85 | (a01 * b00 + a11 * b01 + a21 * b02) | 85 | (a01 * b00 + a11 * b01 + a21 * b02) |
86 | (a01 * b10 + a11 * b11 + a21 * b12) | 86 | (a01 * b10 + a11 * b11 + a21 * b12) |
87 | (a01 * b20 + a11 * b21 + a21 * b22) | 87 | (a01 * b20 + a11 * b21 + a21 * b22) |
88 | 88 | ||
89 | (a02 * b00 + a12 * b01 + a22 * b02) | 89 | (a02 * b00 + a12 * b01 + a22 * b02) |
90 | (a02 * b10 + a12 * b11 + a22 * b12) | 90 | (a02 * b10 + a12 * b11 + a22 * b12) |
91 | (a02 * b20 + a12 * b21 + a22 * b22) | 91 | (a02 * b20 + a12 * b21 + a22 * b22) |
92 | 92 | ||
93 | abs = Spear.Math.Matrix3.map abs | 93 | abs = Spear.Math.Matrix3.map abs |
94 | 94 | ||
95 | signum = Spear.Math.Matrix3.map signum | 95 | signum = Spear.Math.Matrix3.map signum |
96 | 96 | ||
97 | fromInteger i = mat3 i' i' i' i' i' i' i' i' i' where i' = fromInteger i | 97 | fromInteger i = mat3 i' i' i' i' i' i' i' i' i' where i' = fromInteger i |
98 | 98 | ||
99 | 99 | ||
100 | instance Storable Matrix3 where | 100 | instance Storable Matrix3 where |
101 | sizeOf _ = 36 | 101 | sizeOf _ = 36 |
102 | alignment _ = 4 | 102 | alignment _ = 4 |
103 | 103 | ||
104 | peek ptr = do | 104 | peek ptr = do |
105 | a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; | 105 | a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; |
106 | a10 <- peekByteOff ptr 12; a11 <- peekByteOff ptr 16; a12 <- peekByteOff ptr 20; | 106 | a10 <- peekByteOff ptr 12; a11 <- peekByteOff ptr 16; a12 <- peekByteOff ptr 20; |
107 | a20 <- peekByteOff ptr 24; a21 <- peekByteOff ptr 28; a22 <- peekByteOff ptr 32; | 107 | a20 <- peekByteOff ptr 24; a21 <- peekByteOff ptr 28; a22 <- peekByteOff ptr 32; |
108 | 108 | ||
109 | return $ Matrix3 a00 a10 a20 | 109 | return $ Matrix3 a00 a10 a20 |
110 | a01 a11 a21 | 110 | a01 a11 a21 |
111 | a02 a12 a22 | 111 | a02 a12 a22 |
112 | 112 | ||
113 | poke ptr (Matrix3 a00 a01 a02 | 113 | poke ptr (Matrix3 a00 a01 a02 |
114 | a10 a11 a12 | 114 | a10 a11 a12 |
115 | a20 a21 a22) = do | 115 | a20 a21 a22) = do |
116 | pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; | 116 | pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; |
117 | pokeByteOff ptr 12 a10; pokeByteOff ptr 16 a11; pokeByteOff ptr 20 a12; | 117 | pokeByteOff ptr 12 a10; pokeByteOff ptr 16 a11; pokeByteOff ptr 20 a12; |
118 | pokeByteOff ptr 24 a20; pokeByteOff ptr 28 a21; pokeByteOff ptr 32 a22; | 118 | pokeByteOff ptr 24 a20; pokeByteOff ptr 28 a21; pokeByteOff ptr 32 a22; |
119 | 119 | ||
120 | 120 | ||
121 | col0 (Matrix3 a00 _ _ a01 _ _ a02 _ _ ) = vec3 a00 a01 a02 | 121 | col0 (Matrix3 a00 _ _ a01 _ _ a02 _ _ ) = vec3 a00 a01 a02 |
122 | col1 (Matrix3 _ a10 _ _ a11 _ _ a12 _ ) = vec3 a10 a11 a12 | 122 | col1 (Matrix3 _ a10 _ _ a11 _ _ a12 _ ) = vec3 a10 a11 a12 |
123 | col2 (Matrix3 _ _ a20 _ _ a21 _ _ a22) = vec3 a20 a21 a22 | 123 | col2 (Matrix3 _ _ a20 _ _ a21 _ _ a22) = vec3 a20 a21 a22 |
124 | 124 | ||
125 | 125 | ||
126 | row0 (Matrix3 a00 a10 a20 _ _ _ _ _ _ ) = vec3 a00 a10 a20 | 126 | row0 (Matrix3 a00 a10 a20 _ _ _ _ _ _ ) = vec3 a00 a10 a20 |
127 | row1 (Matrix3 _ _ _ a01 a11 a21 _ _ _ ) = vec3 a01 a11 a21 | 127 | row1 (Matrix3 _ _ _ a01 a11 a21 _ _ _ ) = vec3 a01 a11 a21 |
128 | row2 (Matrix3 _ _ _ _ _ _ a02 a12 a22) = vec3 a02 a12 a22 | 128 | row2 (Matrix3 _ _ _ _ _ _ a02 a12 a22) = vec3 a02 a12 a22 |
129 | 129 | ||
130 | 130 | ||
131 | right (Matrix3 a00 _ _ a01 _ _ _ _ _) = vec2 a00 a01 | 131 | right (Matrix3 a00 _ _ a01 _ _ _ _ _) = vec2 a00 a01 |
132 | up (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 | 132 | up (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 |
133 | forward (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 | 133 | forward (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 |
134 | position (Matrix3 _ _ a20 _ _ a21 _ _ _) = vec2 a20 a21 | 134 | position (Matrix3 _ _ a20 _ _ a21 _ _ _) = vec2 a20 a21 |
135 | 135 | ||
136 | 136 | ||
137 | -- | Build a matrix from the specified values. | 137 | -- | Build a matrix from the specified values. |
138 | mat3 = Matrix3 | 138 | mat3 = Matrix3 |
139 | 139 | ||
140 | 140 | ||
141 | -- | Build a matrix from three vectors in 3D. | 141 | -- | Build a matrix from three vectors in 3D. |
142 | mat3fromVec :: Vector3 -> Vector3 -> Vector3 -> Matrix3 | 142 | mat3fromVec :: Vector3 -> Vector3 -> Vector3 -> Matrix3 |
143 | mat3fromVec v0 v1 v2 = Matrix3 | 143 | mat3fromVec v0 v1 v2 = Matrix3 |
144 | (x v0) (x v1) (x v2) | 144 | (x v0) (x v1) (x v2) |
145 | (y v0) (y v1) (y v2) | 145 | (y v0) (y v1) (y v2) |
146 | (z v0) (z v1) (z v2) | 146 | (z v0) (z v1) (z v2) |
147 | 147 | ||
148 | 148 | ||
149 | -- | Build a transformation matrix. | 149 | -- | Build a transformation matrix. |
150 | transform :: Vector2 -- ^ Right vector | 150 | transform :: Vector2 -- ^ Right vector |
151 | -> Vector2 -- ^ Forward vector | 151 | -> Vector2 -- ^ Forward vector |
152 | -> Vector2 -- ^ Position | 152 | -> Vector2 -- ^ Position |
153 | -> Matrix3 -- ^ Transform | 153 | -> Matrix3 -- ^ Transform |
154 | 154 | ||
155 | transform r f p = mat3 | 155 | transform r f p = mat3 |
156 | (x r) (x f) (x p) | 156 | (x r) (x f) (x p) |
157 | (y r) (y f) (y p) | 157 | (y r) (y f) (y p) |
158 | 0 0 1 | 158 | 0 0 1 |
159 | 159 | ||
160 | 160 | ||
161 | -- | Get the translation part of the given transformation matrix. | 161 | -- | Get the translation part of the given transformation matrix. |
162 | translation :: Matrix3 -> Matrix3 | 162 | translation :: Matrix3 -> Matrix3 |
163 | translation (Matrix3 | 163 | translation (Matrix3 |
164 | a00 a10 a20 | 164 | a00 a10 a20 |
165 | a01 a11 a21 | 165 | a01 a11 a21 |
166 | a02 a12 a22) | 166 | a02 a12 a22) |
167 | = mat3 | 167 | = mat3 |
168 | 1 0 a20 | 168 | 1 0 a20 |
169 | 0 1 a21 | 169 | 0 1 a21 |
170 | 0 0 a22 | 170 | 0 0 a22 |
171 | 171 | ||
172 | 172 | ||
173 | -- | Get the rotation part of the given transformationmatrix. | 173 | -- | Get the rotation part of the given transformationmatrix. |
174 | rotation :: Matrix3 -> Matrix3 | 174 | rotation :: Matrix3 -> Matrix3 |
175 | rotation (Matrix3 | 175 | rotation (Matrix3 |
176 | a00 a10 a20 | 176 | a00 a10 a20 |
177 | a01 a11 a21 | 177 | a01 a11 a21 |
178 | a02 a12 a22) | 178 | a02 a12 a22) |
179 | = mat3 | 179 | = mat3 |
180 | a00 a10 0 | 180 | a00 a10 0 |
181 | a01 a11 0 | 181 | a01 a11 0 |
182 | a02 a12 1 | 182 | a02 a12 1 |
183 | 183 | ||
184 | 184 | ||
185 | -- | Return the identity matrix. | 185 | -- | Return the identity matrix. |
186 | id :: Matrix3 | 186 | id :: Matrix3 |
187 | id = mat3 | 187 | id = mat3 |
188 | 1 0 0 | 188 | 1 0 0 |
189 | 0 1 0 | 189 | 0 1 0 |
190 | 0 0 1 | 190 | 0 0 1 |
191 | 191 | ||
192 | 192 | ||
193 | -- | Create a translation matrix. | 193 | -- | Create a translation matrix. |
194 | transl :: Float -- ^ Translation on the x axis | 194 | transl :: Float -- ^ Translation on the x axis |
195 | -> Float -- ^ Translation on the y axis | 195 | -> Float -- ^ Translation on the y axis |
196 | -> Matrix3 | 196 | -> Matrix3 |
197 | 197 | ||
198 | transl tx ty = mat3 | 198 | transl tx ty = mat3 |
199 | 1 0 tx | 199 | 1 0 tx |
200 | 0 1 ty | 200 | 0 1 ty |
201 | 0 0 1 | 201 | 0 0 1 |
202 | 202 | ||
203 | 203 | ||
204 | -- | Create a translation matrix. | 204 | -- | Create a translation matrix. |
205 | translv :: Vector2 -> Matrix3 | 205 | translv :: Vector2 -> Matrix3 |
206 | translv v = mat3 | 206 | translv v = mat3 |
207 | 1 0 (x v) | 207 | 1 0 (x v) |
208 | 0 1 (y v) | 208 | 0 1 (y v) |
209 | 0 0 1 | 209 | 0 0 1 |
210 | 210 | ||
211 | 211 | ||
212 | -- | Create a rotation matrix rotating counter-clockwise about the Z axis. | 212 | -- | Create a rotation matrix rotating counter-clockwise about the Z axis. |
213 | -- | 213 | -- |
214 | -- The given angle must be in degrees. | 214 | -- The given angle must be in degrees. |
215 | rot :: Float -> Matrix3 | 215 | rot :: Float -> Matrix3 |
216 | rot angle = mat3 | 216 | rot angle = mat3 |
217 | c (-s) 0 | 217 | c (-s) 0 |
218 | s c 0 | 218 | s c 0 |
219 | 0 0 1 | 219 | 0 0 1 |
220 | where | 220 | where |
221 | s = sin . fromDeg $ angle | 221 | s = sin . fromDeg $ angle |
222 | c = cos . fromDeg $ angle | 222 | c = cos . fromDeg $ angle |
223 | 223 | ||
224 | 224 | ||
225 | -- | Create a scale matrix. | 225 | -- | Create a scale matrix. |
226 | scale :: Float -> Float -> Float -> Matrix3 | 226 | scale :: Float -> Float -> Float -> Matrix3 |
227 | scale sx sy sz = mat3 | 227 | scale sx sy sz = mat3 |
228 | sx 0 0 | 228 | sx 0 0 |
229 | 0 sy 0 | 229 | 0 sy 0 |
230 | 0 0 sz | 230 | 0 0 sz |
231 | 231 | ||
232 | 232 | ||
233 | -- | Create a scale matrix. | 233 | -- | Create a scale matrix. |
234 | scalev :: Vector3 -> Matrix3 | 234 | scalev :: Vector3 -> Matrix3 |
235 | scalev v = mat3 | 235 | scalev v = mat3 |
236 | sx 0 0 | 236 | sx 0 0 |
237 | 0 sy 0 | 237 | 0 sy 0 |
238 | 0 0 sz | 238 | 0 0 sz |
239 | where | 239 | where |
240 | sx = x v | 240 | sx = x v |
241 | sy = y v | 241 | sy = y v |
242 | sz = z v | 242 | sz = z v |
243 | 243 | ||
244 | 244 | ||
245 | -- | Create an X reflection matrix. | 245 | -- | Create an X reflection matrix. |
246 | reflectX :: Matrix3 | 246 | reflectX :: Matrix3 |
247 | reflectX = mat3 | 247 | reflectX = mat3 |
248 | (-1) 0 0 | 248 | (-1) 0 0 |
249 | 0 1 0 | 249 | 0 1 0 |
250 | 0 0 1 | 250 | 0 0 1 |
251 | 251 | ||
252 | 252 | ||
253 | -- | Create a Y reflection matrix. | 253 | -- | Create a Y reflection matrix. |
254 | reflectY :: Matrix3 | 254 | reflectY :: Matrix3 |
255 | reflectY = mat3 | 255 | reflectY = mat3 |
256 | 1 0 0 | 256 | 1 0 0 |
257 | 0 (-1) 0 | 257 | 0 (-1) 0 |
258 | 0 0 1 | 258 | 0 0 1 |
259 | 259 | ||
260 | 260 | ||
261 | -- | Create a Z reflection matrix. | 261 | -- | Create a Z reflection matrix. |
262 | reflectZ :: Matrix3 | 262 | reflectZ :: Matrix3 |
263 | reflectZ = mat3 | 263 | reflectZ = mat3 |
264 | 1 0 0 | 264 | 1 0 0 |
265 | 0 1 0 | 265 | 0 1 0 |
266 | 0 0 (-1) | 266 | 0 0 (-1) |
267 | 267 | ||
268 | 268 | ||
269 | -- | Transpose the specified matrix. | 269 | -- | Transpose the specified matrix. |
270 | transpose :: Matrix3 -> Matrix3 | 270 | transpose :: Matrix3 -> Matrix3 |
271 | transpose m = mat3 | 271 | transpose m = mat3 |
272 | (m00 m) (m01 m) (m02 m) | 272 | (m00 m) (m01 m) (m02 m) |
273 | (m10 m) (m11 m) (m12 m) | 273 | (m10 m) (m11 m) (m12 m) |
274 | (m20 m) (m21 m) (m22 m) | 274 | (m20 m) (m21 m) (m22 m) |
275 | 275 | ||
276 | 276 | ||
277 | -- | Transform the given point vector in 2D space with the given matrix. | 277 | -- | Transform the given point vector in 2D space with the given matrix. |
278 | mulp :: Matrix3 -> Vector2 -> Vector2 | 278 | mulp :: Matrix3 -> Vector2 -> Vector2 |
279 | mulp m v = vec2 x' y' | 279 | mulp m v = vec2 x' y' |
280 | where | 280 | where |
281 | v' = vec3 (x v) (y v) 1 | 281 | v' = vec3 (x v) (y v) 1 |
282 | x' = row0 m `dot` v' | 282 | x' = row0 m `dot` v' |
283 | y' = row1 m `dot` v' | 283 | y' = row1 m `dot` v' |
284 | 284 | ||
285 | 285 | ||
286 | 286 | ||
287 | -- | Transform the given directional vector in 2D space with the given matrix. | 287 | -- | Transform the given directional vector in 2D space with the given matrix. |
288 | muld :: Matrix3 -> Vector2 -> Vector2 | 288 | muld :: Matrix3 -> Vector2 -> Vector2 |
289 | muld m v = vec2 x' y' | 289 | muld m v = vec2 x' y' |
290 | where | 290 | where |
291 | v' = vec3 (x v) (y v) 0 | 291 | v' = vec3 (x v) (y v) 0 |
292 | x' = row0 m `dot` v' | 292 | x' = row0 m `dot` v' |
293 | y' = row1 m `dot` v' | 293 | y' = row1 m `dot` v' |
294 | 294 | ||
295 | 295 | ||
296 | -- | Transform the given vector in 3D space with the given matrix. | 296 | -- | Transform the given vector in 3D space with the given matrix. |
297 | mul :: Matrix3 -> Vector3 -> Vector3 | 297 | mul :: Matrix3 -> Vector3 -> Vector3 |
298 | mul m v = vec3 x' y' z' | 298 | mul m v = vec3 x' y' z' |
299 | where | 299 | where |
300 | v' = vec3 (x v) (y v) (z v) | 300 | v' = vec3 (x v) (y v) (z v) |
301 | x' = row0 m `dot` v' | 301 | x' = row0 m `dot` v' |
302 | y' = row1 m `dot` v' | 302 | y' = row1 m `dot` v' |
303 | z' = row2 m `dot` v' | 303 | z' = row2 m `dot` v' |
304 | 304 | ||
305 | 305 | ||
306 | -- | Zip two 'Matrix3' together with the specified function. | 306 | -- | Zip two 'Matrix3' together with the specified function. |
307 | zipWith :: (Float -> Float -> Float) -> Matrix3 -> Matrix3 -> Matrix3 | 307 | zipWith :: (Float -> Float -> Float) -> Matrix3 -> Matrix3 -> Matrix3 |
308 | zipWith f a b = Matrix3 | 308 | zipWith f a b = Matrix3 |
309 | (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) | 309 | (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) |
310 | (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) | 310 | (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) |
311 | (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) | 311 | (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) |
312 | 312 | ||
313 | 313 | ||
314 | -- | Map the specified function to the specified 'Matrix3'. | 314 | -- | Map the specified function to the specified 'Matrix3'. |
315 | map :: (Float -> Float) -> Matrix3 -> Matrix3 | 315 | map :: (Float -> Float) -> Matrix3 -> Matrix3 |
316 | map f m = Matrix3 | 316 | map f m = Matrix3 |
317 | (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) | 317 | (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) |
318 | (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) | 318 | (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) |
319 | (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) | 319 | (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) |
320 | 320 | ||
321 | 321 | ||
322 | -- | Compute the inverse transform of the given transformation matrix. | 322 | -- | Compute the inverse transform of the given transformation matrix. |
323 | inverseTransform :: Matrix3 -> Matrix3 | 323 | inverseTransform :: Matrix3 -> Matrix3 |
324 | inverseTransform mat = | 324 | inverseTransform mat = |
325 | let r = right mat | 325 | let r = right mat |
326 | f = forward mat | 326 | f = forward mat |
327 | t = -(position mat) | 327 | t = -(position mat) |
328 | in mat3 | 328 | in mat3 |
329 | (x r) (y r) (t `dot` r) | 329 | (x r) (y r) (t `dot` r) |
330 | (x f) (y f) (t `dot` f) | 330 | (x f) (y f) (t `dot` f) |
331 | 0 0 1 | 331 | 0 0 1 |
332 | 332 | ||
333 | 333 | ||
334 | fromDeg :: (Floating a) => a -> a | 334 | fromDeg :: (Floating a) => a -> a |
335 | fromDeg = (*pi) . (/180) | 335 | fromDeg = (*pi) . (/180) |
diff --git a/Spear/Math/Matrix4.hs b/Spear/Math/Matrix4.hs index e1b1d04..12eb031 100644 --- a/Spear/Math/Matrix4.hs +++ b/Spear/Math/Matrix4.hs | |||
@@ -1,650 +1,650 @@ | |||
1 | module Spear.Math.Matrix4 | 1 | module Spear.Math.Matrix4 |
2 | ( | 2 | ( |
3 | Matrix4 | 3 | Matrix4 |
4 | -- * Accessors | 4 | -- * Accessors |
5 | , m00, m01, m02, m03 | 5 | , m00, m01, m02, m03 |
6 | , m10, m11, m12, m13 | 6 | , m10, m11, m12, m13 |
7 | , m20, m21, m22, m23 | 7 | , m20, m21, m22, m23 |
8 | , m30, m31, m32, m33 | 8 | , m30, m31, m32, m33 |
9 | , col0, col1, col2, col3 | 9 | , col0, col1, col2, col3 |
10 | , row0, row1, row2, row3 | 10 | , row0, row1, row2, row3 |
11 | , right, up, forward, position | 11 | , right, up, forward, position |
12 | -- * Construction | 12 | -- * Construction |
13 | , mat4 | 13 | , mat4 |
14 | , mat4fromVec | 14 | , mat4fromVec |
15 | , transform | 15 | , transform |
16 | , translation | 16 | , translation |
17 | , rotation | 17 | , rotation |
18 | , lookAt | 18 | , lookAt |
19 | , Spear.Math.Matrix4.id | 19 | , Spear.Math.Matrix4.id |
20 | -- * Transformations | 20 | -- * Transformations |
21 | -- ** Translation | 21 | -- ** Translation |
22 | , transl | 22 | , transl |
23 | , translv | 23 | , translv |
24 | -- ** Rotation | 24 | -- ** Rotation |
25 | , rotX | 25 | , rotX |
26 | , rotY | 26 | , rotY |
27 | , rotZ | 27 | , rotZ |
28 | , axisAngle | 28 | , axisAngle |
29 | -- ** Scale | 29 | -- ** Scale |
30 | , Spear.Math.Matrix4.scale | 30 | , Spear.Math.Matrix4.scale |
31 | , scalev | 31 | , scalev |
32 | -- ** Reflection | 32 | -- ** Reflection |
33 | , reflectX | 33 | , reflectX |
34 | , reflectY | 34 | , reflectY |
35 | , reflectZ | 35 | , reflectZ |
36 | -- ** Projection | 36 | -- ** Projection |
37 | , ortho | 37 | , ortho |
38 | , perspective | 38 | , perspective |
39 | , planeProj | 39 | , planeProj |
40 | -- * Operations | 40 | -- * Operations |
41 | , Spear.Math.Matrix4.zipWith | 41 | , Spear.Math.Matrix4.zipWith |
42 | , Spear.Math.Matrix4.map | 42 | , Spear.Math.Matrix4.map |
43 | , transpose | 43 | , transpose |
44 | , inverseTransform | 44 | , inverseTransform |
45 | , inverse | 45 | , inverse |
46 | , mul | 46 | , mul |
47 | , mulp | 47 | , mulp |
48 | , muld | 48 | , muld |
49 | , mul' | 49 | , mul' |
50 | ) | 50 | ) |
51 | where | 51 | where |
52 | 52 | ||
53 | 53 | ||
54 | import Spear.Math.Vector | 54 | import Spear.Math.Vector |
55 | 55 | ||
56 | import Foreign.Storable | 56 | import Foreign.Storable |
57 | 57 | ||
58 | 58 | ||
59 | -- | Represents a 4x4 column major matrix. | 59 | -- | Represents a 4x4 column major matrix. |
60 | data Matrix4 = Matrix4 | 60 | data Matrix4 = Matrix4 |
61 | { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float, m30 :: {-# UNPACK #-} !Float | 61 | { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float, m30 :: {-# UNPACK #-} !Float |
62 | , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float, m31 :: {-# UNPACK #-} !Float | 62 | , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float, m31 :: {-# UNPACK #-} !Float |
63 | , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float, m32 :: {-# UNPACK #-} !Float | 63 | , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float, m32 :: {-# UNPACK #-} !Float |
64 | , m03 :: {-# UNPACK #-} !Float, m13 :: {-# UNPACK #-} !Float, m23 :: {-# UNPACK #-} !Float, m33 :: {-# UNPACK #-} !Float | 64 | , m03 :: {-# UNPACK #-} !Float, m13 :: {-# UNPACK #-} !Float, m23 :: {-# UNPACK #-} !Float, m33 :: {-# UNPACK #-} !Float |
65 | } | 65 | } |
66 | 66 | ||
67 | 67 | ||
68 | instance Show Matrix4 where | 68 | instance Show Matrix4 where |
69 | 69 | ||
70 | show (Matrix4 m00 m10 m20 m30 m01 m11 m21 m31 m02 m12 m22 m32 m03 m13 m23 m33) = | 70 | show (Matrix4 m00 m10 m20 m30 m01 m11 m21 m31 m02 m12 m22 m32 m03 m13 m23 m33) = |
71 | show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ ", " ++ show' m30 ++ "\n" ++ | 71 | show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ ", " ++ show' m30 ++ "\n" ++ |
72 | show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ ", " ++ show' m31 ++ "\n" ++ | 72 | show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ ", " ++ show' m31 ++ "\n" ++ |
73 | show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ ", " ++ show' m32 ++ "\n" ++ | 73 | show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ ", " ++ show' m32 ++ "\n" ++ |
74 | show' m03 ++ ", " ++ show' m13 ++ ", " ++ show' m23 ++ ", " ++ show' m33 ++ "\n" | 74 | show' m03 ++ ", " ++ show' m13 ++ ", " ++ show' m23 ++ ", " ++ show' m33 ++ "\n" |
75 | where | 75 | where |
76 | show' f = if abs f < 0.0000001 then "0" else show f | 76 | show' f = if abs f < 0.0000001 then "0" else show f |
77 | 77 | ||
78 | 78 | ||
79 | instance Num Matrix4 where | 79 | instance Num Matrix4 where |
80 | (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) | 80 | (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) |
81 | + (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) | 81 | + (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) |
82 | = Matrix4 (a00 + b00) (a01 + b01) (a02 + b02) (a03 + b03) | 82 | = Matrix4 (a00 + b00) (a01 + b01) (a02 + b02) (a03 + b03) |
83 | (a04 + b04) (a05 + b05) (a06 + b06) (a07 + b07) | 83 | (a04 + b04) (a05 + b05) (a06 + b06) (a07 + b07) |
84 | (a08 + b08) (a09 + b09) (a10 + b10) (a11 + b11) | 84 | (a08 + b08) (a09 + b09) (a10 + b10) (a11 + b11) |
85 | (a12 + b12) (a13 + b13) (a14 + b14) (a15 + b15) | 85 | (a12 + b12) (a13 + b13) (a14 + b14) (a15 + b15) |
86 | 86 | ||
87 | (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) | 87 | (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) |
88 | - (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) | 88 | - (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) |
89 | = Matrix4 (a00 - b00) (a01 - b01) (a02 - b02) (a03 - b03) | 89 | = Matrix4 (a00 - b00) (a01 - b01) (a02 - b02) (a03 - b03) |
90 | (a04 - b04) (a05 - b05) (a06 - b06) (a07 - b07) | 90 | (a04 - b04) (a05 - b05) (a06 - b06) (a07 - b07) |
91 | (a08 - b08) (a09 - b09) (a10 - b10) (a11 - b11) | 91 | (a08 - b08) (a09 - b09) (a10 - b10) (a11 - b11) |
92 | (a12 - b12) (a13 - b13) (a14 - b14) (a15 - b15) | 92 | (a12 - b12) (a13 - b13) (a14 - b14) (a15 - b15) |
93 | 93 | ||
94 | (Matrix4 a00 a10 a20 a30 a01 a11 a21 a31 a02 a12 a22 a32 a03 a13 a23 a33) | 94 | (Matrix4 a00 a10 a20 a30 a01 a11 a21 a31 a02 a12 a22 a32 a03 a13 a23 a33) |
95 | * (Matrix4 b00 b10 b20 b30 b01 b11 b21 b31 b02 b12 b22 b32 b03 b13 b23 b33) | 95 | * (Matrix4 b00 b10 b20 b30 b01 b11 b21 b31 b02 b12 b22 b32 b03 b13 b23 b33) |
96 | = Matrix4 (a00 * b00 + a10 * b01 + a20 * b02 + a30 * b03) | 96 | = Matrix4 (a00 * b00 + a10 * b01 + a20 * b02 + a30 * b03) |
97 | (a00 * b10 + a10 * b11 + a20 * b12 + a30 * b13) | 97 | (a00 * b10 + a10 * b11 + a20 * b12 + a30 * b13) |
98 | (a00 * b20 + a10 * b21 + a20 * b22 + a30 * b23) | 98 | (a00 * b20 + a10 * b21 + a20 * b22 + a30 * b23) |
99 | (a00 * b30 + a10 * b31 + a20 * b32 + a30 * b33) | 99 | (a00 * b30 + a10 * b31 + a20 * b32 + a30 * b33) |
100 | 100 | ||
101 | (a01 * b00 + a11 * b01 + a21 * b02 + a31 * b03) | 101 | (a01 * b00 + a11 * b01 + a21 * b02 + a31 * b03) |
102 | (a01 * b10 + a11 * b11 + a21 * b12 + a31 * b13) | 102 | (a01 * b10 + a11 * b11 + a21 * b12 + a31 * b13) |
103 | (a01 * b20 + a11 * b21 + a21 * b22 + a31 * b23) | 103 | (a01 * b20 + a11 * b21 + a21 * b22 + a31 * b23) |
104 | (a01 * b30 + a11 * b31 + a21 * b32 + a31 * b33) | 104 | (a01 * b30 + a11 * b31 + a21 * b32 + a31 * b33) |
105 | 105 | ||
106 | (a02 * b00 + a12 * b01 + a22 * b02 + a32 * b03) | 106 | (a02 * b00 + a12 * b01 + a22 * b02 + a32 * b03) |
107 | (a02 * b10 + a12 * b11 + a22 * b12 + a32 * b13) | 107 | (a02 * b10 + a12 * b11 + a22 * b12 + a32 * b13) |
108 | (a02 * b20 + a12 * b21 + a22 * b22 + a32 * b23) | 108 | (a02 * b20 + a12 * b21 + a22 * b22 + a32 * b23) |
109 | (a02 * b30 + a12 * b31 + a22 * b32 + a32 * b33) | 109 | (a02 * b30 + a12 * b31 + a22 * b32 + a32 * b33) |
110 | 110 | ||
111 | (a03 * b00 + a13 * b01 + a23 * b02 + a33 * b03) | 111 | (a03 * b00 + a13 * b01 + a23 * b02 + a33 * b03) |
112 | (a03 * b10 + a13 * b11 + a23 * b12 + a33 * b13) | 112 | (a03 * b10 + a13 * b11 + a23 * b12 + a33 * b13) |
113 | (a03 * b20 + a13 * b21 + a23 * b22 + a33 * b23) | 113 | (a03 * b20 + a13 * b21 + a23 * b22 + a33 * b23) |
114 | (a03 * b30 + a13 * b31 + a23 * b32 + a33 * b33) | 114 | (a03 * b30 + a13 * b31 + a23 * b32 + a33 * b33) |
115 | 115 | ||
116 | abs = Spear.Math.Matrix4.map abs | 116 | abs = Spear.Math.Matrix4.map abs |
117 | 117 | ||
118 | signum = Spear.Math.Matrix4.map signum | 118 | signum = Spear.Math.Matrix4.map signum |
119 | 119 | ||
120 | fromInteger i = mat4 i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' where i' = fromInteger i | 120 | fromInteger i = mat4 i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' where i' = fromInteger i |
121 | 121 | ||
122 | 122 | ||
123 | instance Storable Matrix4 where | 123 | instance Storable Matrix4 where |
124 | sizeOf _ = 64 | 124 | sizeOf _ = 64 |
125 | alignment _ = 4 | 125 | alignment _ = 4 |
126 | 126 | ||
127 | peek ptr = do | 127 | peek ptr = do |
128 | a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; a03 <- peekByteOff ptr 12; | 128 | a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; a03 <- peekByteOff ptr 12; |
129 | a10 <- peekByteOff ptr 16; a11 <- peekByteOff ptr 20; a12 <- peekByteOff ptr 24; a13 <- peekByteOff ptr 28; | 129 | a10 <- peekByteOff ptr 16; a11 <- peekByteOff ptr 20; a12 <- peekByteOff ptr 24; a13 <- peekByteOff ptr 28; |
130 | a20 <- peekByteOff ptr 32; a21 <- peekByteOff ptr 36; a22 <- peekByteOff ptr 40; a23 <- peekByteOff ptr 44; | 130 | a20 <- peekByteOff ptr 32; a21 <- peekByteOff ptr 36; a22 <- peekByteOff ptr 40; a23 <- peekByteOff ptr 44; |
131 | a30 <- peekByteOff ptr 48; a31 <- peekByteOff ptr 52; a32 <- peekByteOff ptr 56; a33 <- peekByteOff ptr 60; | 131 | a30 <- peekByteOff ptr 48; a31 <- peekByteOff ptr 52; a32 <- peekByteOff ptr 56; a33 <- peekByteOff ptr 60; |
132 | 132 | ||
133 | return $ Matrix4 a00 a10 a20 a30 | 133 | return $ Matrix4 a00 a10 a20 a30 |
134 | a01 a11 a21 a31 | 134 | a01 a11 a21 a31 |
135 | a02 a12 a22 a32 | 135 | a02 a12 a22 a32 |
136 | a03 a13 a23 a33 | 136 | a03 a13 a23 a33 |
137 | 137 | ||
138 | poke ptr (Matrix4 a00 a10 a20 a30 | 138 | poke ptr (Matrix4 a00 a10 a20 a30 |
139 | a01 a11 a21 a31 | 139 | a01 a11 a21 a31 |
140 | a02 a12 a22 a32 | 140 | a02 a12 a22 a32 |
141 | a03 a13 a23 a33) = do | 141 | a03 a13 a23 a33) = do |
142 | pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; pokeByteOff ptr 12 a03; | 142 | pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; pokeByteOff ptr 12 a03; |
143 | pokeByteOff ptr 16 a10; pokeByteOff ptr 20 a11; pokeByteOff ptr 24 a12; pokeByteOff ptr 28 a13; | 143 | pokeByteOff ptr 16 a10; pokeByteOff ptr 20 a11; pokeByteOff ptr 24 a12; pokeByteOff ptr 28 a13; |
144 | pokeByteOff ptr 32 a20; pokeByteOff ptr 36 a21; pokeByteOff ptr 40 a22; pokeByteOff ptr 44 a23; | 144 | pokeByteOff ptr 32 a20; pokeByteOff ptr 36 a21; pokeByteOff ptr 40 a22; pokeByteOff ptr 44 a23; |
145 | pokeByteOff ptr 48 a30; pokeByteOff ptr 52 a31; pokeByteOff ptr 56 a32; pokeByteOff ptr 60 a33; | 145 | pokeByteOff ptr 48 a30; pokeByteOff ptr 52 a31; pokeByteOff ptr 56 a32; pokeByteOff ptr 60 a33; |
146 | 146 | ||
147 | 147 | ||
148 | col0 (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ a03 _ _ _ ) = vec4 a00 a01 a02 a03 | 148 | col0 (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ a03 _ _ _ ) = vec4 a00 a01 a02 a03 |
149 | col1 (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ a13 _ _ ) = vec4 a10 a11 a12 a13 | 149 | col1 (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ a13 _ _ ) = vec4 a10 a11 a12 a13 |
150 | col2 (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ a23 _ ) = vec4 a20 a21 a22 a23 | 150 | col2 (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ a23 _ ) = vec4 a20 a21 a22 a23 |
151 | col3 (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ a33) = vec4 a30 a31 a32 a33 | 151 | col3 (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ a33) = vec4 a30 a31 a32 a33 |
152 | 152 | ||
153 | 153 | ||
154 | row0 (Matrix4 a00 a01 a02 a03 _ _ _ _ _ _ _ _ _ _ _ _ ) = vec4 a00 a01 a02 a03 | 154 | row0 (Matrix4 a00 a01 a02 a03 _ _ _ _ _ _ _ _ _ _ _ _ ) = vec4 a00 a01 a02 a03 |
155 | row1 (Matrix4 _ _ _ _ a10 a11 a12 a13 _ _ _ _ _ _ _ _ ) = vec4 a10 a11 a12 a13 | 155 | row1 (Matrix4 _ _ _ _ a10 a11 a12 a13 _ _ _ _ _ _ _ _ ) = vec4 a10 a11 a12 a13 |
156 | row2 (Matrix4 _ _ _ _ _ _ _ _ a20 a21 a22 a23 _ _ _ _ ) = vec4 a20 a21 a22 a23 | 156 | row2 (Matrix4 _ _ _ _ _ _ _ _ a20 a21 a22 a23 _ _ _ _ ) = vec4 a20 a21 a22 a23 |
157 | row3 (Matrix4 _ _ _ _ _ _ _ _ _ _ _ _ a30 a31 a32 a33) = vec4 a30 a31 a32 a33 | 157 | row3 (Matrix4 _ _ _ _ _ _ _ _ _ _ _ _ a30 a31 a32 a33) = vec4 a30 a31 a32 a33 |
158 | 158 | ||
159 | 159 | ||
160 | right (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ _ _ _ _) = vec3 a00 a01 a02 | 160 | right (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ _ _ _ _) = vec3 a00 a01 a02 |
161 | up (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ _ _ _) = vec3 a10 a11 a12 | 161 | up (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ _ _ _) = vec3 a10 a11 a12 |
162 | forward (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ _ _) = vec3 a20 a21 a22 | 162 | forward (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ _ _) = vec3 a20 a21 a22 |
163 | position (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ _) = vec3 a30 a31 a32 | 163 | position (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ _) = vec3 a30 a31 a32 |
164 | 164 | ||
165 | 165 | ||
166 | -- | Build a matrix from the specified values. | 166 | -- | Build a matrix from the specified values. |
167 | mat4 = Matrix4 | 167 | mat4 = Matrix4 |
168 | 168 | ||
169 | 169 | ||
170 | -- | Build a matrix from four vectors in 4D. | 170 | -- | Build a matrix from four vectors in 4D. |
171 | mat4fromVec :: Vector4 -> Vector4 -> Vector4 -> Vector4 -> Matrix4 | 171 | mat4fromVec :: Vector4 -> Vector4 -> Vector4 -> Vector4 -> Matrix4 |
172 | mat4fromVec v0 v1 v2 v3 = Matrix4 | 172 | mat4fromVec v0 v1 v2 v3 = Matrix4 |
173 | (x v0) (x v1) (x v2) (x v3) | 173 | (x v0) (x v1) (x v2) (x v3) |
174 | (y v0) (y v1) (y v2) (y v3) | 174 | (y v0) (y v1) (y v2) (y v3) |
175 | (z v0) (z v1) (z v2) (z v3) | 175 | (z v0) (z v1) (z v2) (z v3) |
176 | (w v0) (w v1) (w v2) (w v3) | 176 | (w v0) (w v1) (w v2) (w v3) |
177 | 177 | ||
178 | 178 | ||
179 | -- | Build a transformation 'Matrix4' from the given vectors. | 179 | -- | Build a transformation 'Matrix4' from the given vectors. |
180 | transform :: Vector3 -- ^ Right vector. | 180 | transform :: Vector3 -- ^ Right vector. |
181 | -> Vector3 -- ^ Up vector. | 181 | -> Vector3 -- ^ Up vector. |
182 | -> Vector3 -- ^ Forward vector. | 182 | -> Vector3 -- ^ Forward vector. |
183 | -> Vector3 -- ^ Position. | 183 | -> Vector3 -- ^ Position. |
184 | -> Matrix4 | 184 | -> Matrix4 |
185 | 185 | ||
186 | transform right up fwd pos = mat4 | 186 | transform right up fwd pos = mat4 |
187 | (x right) (x up) (x fwd) (x pos) | 187 | (x right) (x up) (x fwd) (x pos) |
188 | (y right) (y up) (y fwd) (y pos) | 188 | (y right) (y up) (y fwd) (y pos) |
189 | (z right) (z up) (z fwd) (z pos) | 189 | (z right) (z up) (z fwd) (z pos) |
190 | 0 0 0 1 | 190 | 0 0 0 1 |
191 | 191 | ||
192 | 192 | ||
193 | -- | Get the translation part of the given transformation matrix. | 193 | -- | Get the translation part of the given transformation matrix. |
194 | translation :: Matrix4 -> Matrix4 | 194 | translation :: Matrix4 -> Matrix4 |
195 | translation (Matrix4 | 195 | translation (Matrix4 |
196 | a00 a10 a20 a30 | 196 | a00 a10 a20 a30 |
197 | a01 a11 a21 a31 | 197 | a01 a11 a21 a31 |
198 | a02 a12 a22 a32 | 198 | a02 a12 a22 a32 |
199 | a03 a13 a23 a33) | 199 | a03 a13 a23 a33) |
200 | = mat4 | 200 | = mat4 |
201 | 1 0 0 a30 | 201 | 1 0 0 a30 |
202 | 0 1 0 a31 | 202 | 0 1 0 a31 |
203 | 0 0 1 a32 | 203 | 0 0 1 a32 |
204 | 0 0 0 a33 | 204 | 0 0 0 a33 |
205 | 205 | ||
206 | 206 | ||
207 | -- | Get the rotation part of the given transformation matrix. | 207 | -- | Get the rotation part of the given transformation matrix. |
208 | rotation :: Matrix4 -> Matrix4 | 208 | rotation :: Matrix4 -> Matrix4 |
209 | rotation (Matrix4 | 209 | rotation (Matrix4 |
210 | a00 a10 a20 a30 | 210 | a00 a10 a20 a30 |
211 | a01 a11 a21 a31 | 211 | a01 a11 a21 a31 |
212 | a02 a12 a22 a32 | 212 | a02 a12 a22 a32 |
213 | a03 a13 a23 a33) | 213 | a03 a13 a23 a33) |
214 | = mat4 | 214 | = mat4 |
215 | a00 a10 a20 0 | 215 | a00 a10 a20 0 |
216 | a01 a11 a21 0 | 216 | a01 a11 a21 0 |
217 | a02 a12 a22 0 | 217 | a02 a12 a22 0 |
218 | a03 a13 a23 1 | 218 | a03 a13 a23 1 |
219 | 219 | ||
220 | 220 | ||
221 | -- | Build a transformation 'Matrix4' defined by the given position and target. | 221 | -- | Build a transformation 'Matrix4' defined by the given position and target. |
222 | lookAt :: Vector3 -- ^ Eye position. | 222 | lookAt :: Vector3 -- ^ Eye position. |
223 | -> Vector3 -- ^ Target point. | 223 | -> Vector3 -- ^ Target point. |
224 | -> Matrix4 | 224 | -> Matrix4 |
225 | 225 | ||
226 | lookAt pos target = | 226 | lookAt pos target = |
227 | let fwd = normalise $ target - pos | 227 | let fwd = normalise $ target - pos |
228 | r = fwd `cross` unity3 | 228 | r = fwd `cross` unity3 |
229 | u = r `cross` fwd | 229 | u = r `cross` fwd |
230 | in | 230 | in |
231 | transform r u (-fwd) pos | 231 | transform r u (-fwd) pos |
232 | 232 | ||
233 | 233 | ||
234 | -- | Zip two matrices together with the specified function. | 234 | -- | Zip two matrices together with the specified function. |
235 | zipWith :: (Float -> Float -> Float) -> Matrix4 -> Matrix4 -> Matrix4 | 235 | zipWith :: (Float -> Float -> Float) -> Matrix4 -> Matrix4 -> Matrix4 |
236 | zipWith f a b = Matrix4 | 236 | zipWith f a b = Matrix4 |
237 | (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) (f (m30 a) (m30 b)) | 237 | (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) (f (m30 a) (m30 b)) |
238 | (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) (f (m31 a) (m31 b)) | 238 | (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) (f (m31 a) (m31 b)) |
239 | (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) (f (m32 a) (m32 b)) | 239 | (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) (f (m32 a) (m32 b)) |
240 | (f (m03 a) (m03 b)) (f (m13 a) (m13 b)) (f (m23 a) (m23 b)) (f (m33 a) (m33 b)) | 240 | (f (m03 a) (m03 b)) (f (m13 a) (m13 b)) (f (m23 a) (m23 b)) (f (m33 a) (m33 b)) |
241 | 241 | ||
242 | 242 | ||
243 | -- | Map the specified function to the specified matrix. | 243 | -- | Map the specified function to the specified matrix. |
244 | map :: (Float -> Float) -> Matrix4 -> Matrix4 | 244 | map :: (Float -> Float) -> Matrix4 -> Matrix4 |
245 | map f m = Matrix4 | 245 | map f m = Matrix4 |
246 | (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) (f . m30 $ m) | 246 | (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) (f . m30 $ m) |
247 | (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) (f . m31 $ m) | 247 | (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) (f . m31 $ m) |
248 | (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) (f . m32 $ m) | 248 | (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) (f . m32 $ m) |
249 | (f . m03 $ m) (f . m13 $ m) (f . m23 $ m) (f . m33 $ m) | 249 | (f . m03 $ m) (f . m13 $ m) (f . m23 $ m) (f . m33 $ m) |
250 | 250 | ||
251 | 251 | ||
252 | -- | Return the identity matrix. | 252 | -- | Return the identity matrix. |
253 | id :: Matrix4 | 253 | id :: Matrix4 |
254 | id = mat4 | 254 | id = mat4 |
255 | 1 0 0 0 | 255 | 1 0 0 0 |
256 | 0 1 0 0 | 256 | 0 1 0 0 |
257 | 0 0 1 0 | 257 | 0 0 1 0 |
258 | 0 0 0 1 | 258 | 0 0 0 1 |
259 | 259 | ||
260 | 260 | ||
261 | -- | Create a translation matrix. | 261 | -- | Create a translation matrix. |
262 | transl :: Float -> Float -> Float -> Matrix4 | 262 | transl :: Float -> Float -> Float -> Matrix4 |
263 | transl x y z = mat4 | 263 | transl x y z = mat4 |
264 | 1 0 0 x | 264 | 1 0 0 x |
265 | 0 1 0 y | 265 | 0 1 0 y |
266 | 0 0 1 z | 266 | 0 0 1 z |
267 | 0 0 0 1 | 267 | 0 0 0 1 |
268 | 268 | ||
269 | 269 | ||
270 | -- | Create a translation matrix. | 270 | -- | Create a translation matrix. |
271 | translv :: Vector3 -> Matrix4 | 271 | translv :: Vector3 -> Matrix4 |
272 | translv v = mat4 | 272 | translv v = mat4 |
273 | 1 0 0 (x v) | 273 | 1 0 0 (x v) |
274 | 0 1 0 (y v) | 274 | 0 1 0 (y v) |
275 | 0 0 1 (z v) | 275 | 0 0 1 (z v) |
276 | 0 0 0 1 | 276 | 0 0 0 1 |
277 | 277 | ||
278 | 278 | ||
279 | -- | Create a rotation matrix rotating about the X axis. | 279 | -- | Create a rotation matrix rotating about the X axis. |
280 | -- The given angle must be in degrees. | 280 | -- The given angle must be in degrees. |
281 | rotX :: Float -> Matrix4 | 281 | rotX :: Float -> Matrix4 |
282 | rotX angle = mat4 | 282 | rotX angle = mat4 |
283 | 1 0 0 0 | 283 | 1 0 0 0 |
284 | 0 c (-s) 0 | 284 | 0 c (-s) 0 |
285 | 0 s c 0 | 285 | 0 s c 0 |
286 | 0 0 0 1 | 286 | 0 0 0 1 |
287 | where | 287 | where |
288 | s = sin . toRAD $ angle | 288 | s = sin . toRAD $ angle |
289 | c = cos . toRAD $ angle | 289 | c = cos . toRAD $ angle |
290 | 290 | ||
291 | 291 | ||
292 | -- | Create a rotation matrix rotating about the Y axis. | 292 | -- | Create a rotation matrix rotating about the Y axis. |
293 | -- The given angle must be in degrees. | 293 | -- The given angle must be in degrees. |
294 | rotY :: Float -> Matrix4 | 294 | rotY :: Float -> Matrix4 |
295 | rotY angle = mat4 | 295 | rotY angle = mat4 |
296 | c 0 s 0 | 296 | c 0 s 0 |
297 | 0 1 0 0 | 297 | 0 1 0 0 |
298 | (-s) 0 c 0 | 298 | (-s) 0 c 0 |
299 | 0 0 0 1 | 299 | 0 0 0 1 |
300 | where | 300 | where |
301 | s = sin . toRAD $ angle | 301 | s = sin . toRAD $ angle |
302 | c = cos . toRAD $ angle | 302 | c = cos . toRAD $ angle |
303 | 303 | ||
304 | 304 | ||
305 | -- | Create a rotation matrix rotating about the Z axis. | 305 | -- | Create a rotation matrix rotating about the Z axis. |
306 | -- The given angle must be in degrees. | 306 | -- The given angle must be in degrees. |
307 | rotZ :: Float -> Matrix4 | 307 | rotZ :: Float -> Matrix4 |
308 | rotZ angle = mat4 | 308 | rotZ angle = mat4 |
309 | c (-s) 0 0 | 309 | c (-s) 0 0 |
310 | s c 0 0 | 310 | s c 0 0 |
311 | 0 0 1 0 | 311 | 0 0 1 0 |
312 | 0 0 0 1 | 312 | 0 0 0 1 |
313 | where | 313 | where |
314 | s = sin . toRAD $ angle | 314 | s = sin . toRAD $ angle |
315 | c = cos . toRAD $ angle | 315 | c = cos . toRAD $ angle |
316 | 316 | ||
317 | 317 | ||
318 | -- | Create a rotation matrix rotating about the specified axis. | 318 | -- | Create a rotation matrix rotating about the specified axis. |
319 | -- The given angle must be in degrees. | 319 | -- The given angle must be in degrees. |
320 | axisAngle :: Vector3 -> Float -> Matrix4 | 320 | axisAngle :: Vector3 -> Float -> Matrix4 |
321 | axisAngle v angle = mat4 | 321 | axisAngle v angle = mat4 |
322 | (c + omc*ax^2) (omc*xy-sz) (omc*xz+sy) 0 | 322 | (c + omc*ax^2) (omc*xy-sz) (omc*xz+sy) 0 |
323 | (omc*xy+sz) (c+omc*ay^2) (omc*yz-sx) 0 | 323 | (omc*xy+sz) (c+omc*ay^2) (omc*yz-sx) 0 |
324 | (omc*xz-sy) (omc*yz+sx) (c+omc*az^2) 0 | 324 | (omc*xz-sy) (omc*yz+sx) (c+omc*az^2) 0 |
325 | 0 0 0 1 | 325 | 0 0 0 1 |
326 | where | 326 | where |
327 | ax = x v | 327 | ax = x v |
328 | ay = y v | 328 | ay = y v |
329 | az = z v | 329 | az = z v |
330 | s = sin . toRAD $ angle | 330 | s = sin . toRAD $ angle |
331 | c = cos . toRAD $ angle | 331 | c = cos . toRAD $ angle |
332 | xy = ax*ay | 332 | xy = ax*ay |
333 | xz = ax*az | 333 | xz = ax*az |
334 | yz = ay*az | 334 | yz = ay*az |
335 | sx = s*ax | 335 | sx = s*ax |
336 | sy = s*ay | 336 | sy = s*ay |
337 | sz = s*az | 337 | sz = s*az |
338 | omc = 1 - c | 338 | omc = 1 - c |
339 | 339 | ||
340 | 340 | ||
341 | -- | Create a scale matrix. | 341 | -- | Create a scale matrix. |
342 | scale :: Float -> Float -> Float -> Matrix4 | 342 | scale :: Float -> Float -> Float -> Matrix4 |
343 | scale sx sy sz = mat4 | 343 | scale sx sy sz = mat4 |
344 | sx 0 0 0 | 344 | sx 0 0 0 |
345 | 0 sy 0 0 | 345 | 0 sy 0 0 |
346 | 0 0 sz 0 | 346 | 0 0 sz 0 |
347 | 0 0 0 1 | 347 | 0 0 0 1 |
348 | 348 | ||
349 | 349 | ||
350 | -- | Create a scale matrix. | 350 | -- | Create a scale matrix. |
351 | scalev :: Vector3 -> Matrix4 | 351 | scalev :: Vector3 -> Matrix4 |
352 | scalev v = mat4 | 352 | scalev v = mat4 |
353 | sx 0 0 0 | 353 | sx 0 0 0 |
354 | 0 sy 0 0 | 354 | 0 sy 0 0 |
355 | 0 0 sz 0 | 355 | 0 0 sz 0 |
356 | 0 0 0 1 | 356 | 0 0 0 1 |
357 | where | 357 | where |
358 | sx = x v | 358 | sx = x v |
359 | sy = y v | 359 | sy = y v |
360 | sz = z v | 360 | sz = z v |
361 | 361 | ||
362 | 362 | ||
363 | -- | Create an X reflection matrix. | 363 | -- | Create an X reflection matrix. |
364 | reflectX :: Matrix4 | 364 | reflectX :: Matrix4 |
365 | reflectX = mat4 | 365 | reflectX = mat4 |
366 | (-1) 0 0 0 | 366 | (-1) 0 0 0 |
367 | 0 1 0 0 | 367 | 0 1 0 0 |
368 | 0 0 1 0 | 368 | 0 0 1 0 |
369 | 0 0 0 1 | 369 | 0 0 0 1 |
370 | 370 | ||
371 | 371 | ||
372 | -- | Create a Y reflection matrix. | 372 | -- | Create a Y reflection matrix. |
373 | reflectY :: Matrix4 | 373 | reflectY :: Matrix4 |
374 | reflectY = mat4 | 374 | reflectY = mat4 |
375 | 1 0 0 0 | 375 | 1 0 0 0 |
376 | 0 (-1) 0 0 | 376 | 0 (-1) 0 0 |
377 | 0 0 1 0 | 377 | 0 0 1 0 |
378 | 0 0 0 1 | 378 | 0 0 0 1 |
379 | 379 | ||
380 | 380 | ||
381 | -- | Create a Z reflection matrix. | 381 | -- | Create a Z reflection matrix. |
382 | reflectZ :: Matrix4 | 382 | reflectZ :: Matrix4 |
383 | reflectZ = mat4 | 383 | reflectZ = mat4 |
384 | 1 0 0 0 | 384 | 1 0 0 0 |
385 | 0 1 0 0 | 385 | 0 1 0 0 |
386 | 0 0 (-1) 0 | 386 | 0 0 (-1) 0 |
387 | 0 0 0 1 | 387 | 0 0 0 1 |
388 | 388 | ||
389 | 389 | ||
390 | -- | Create an orthogonal projection matrix. | 390 | -- | Create an orthogonal projection matrix. |
391 | ortho :: Float -- ^ Left. | 391 | ortho :: Float -- ^ Left. |
392 | -> Float -- ^ Right. | 392 | -> Float -- ^ Right. |
393 | -> Float -- ^ Bottom. | 393 | -> Float -- ^ Bottom. |
394 | -> Float -- ^ Top. | 394 | -> Float -- ^ Top. |
395 | -> Float -- ^ Near clip. | 395 | -> Float -- ^ Near clip. |
396 | -> Float -- ^ Far clip. | 396 | -> Float -- ^ Far clip. |
397 | -> Matrix4 | 397 | -> Matrix4 |
398 | 398 | ||
399 | ortho l r b t n f = | 399 | ortho l r b t n f = |
400 | let tx = (-(r+l)/(r-l)) | 400 | let tx = (-(r+l)/(r-l)) |
401 | ty = (-(t+b)/(t-b)) | 401 | ty = (-(t+b)/(t-b)) |
402 | tz = (-(f+n)/(f-n)) | 402 | tz = (-(f+n)/(f-n)) |
403 | in mat4 | 403 | in mat4 |
404 | (2/(r-l)) 0 0 tx | 404 | (2/(r-l)) 0 0 tx |
405 | 0 (2/(t-b)) 0 ty | 405 | 0 (2/(t-b)) 0 ty |
406 | 0 0 ((-2)/(f-n)) tz | 406 | 0 0 ((-2)/(f-n)) tz |
407 | 0 0 0 1 | 407 | 0 0 0 1 |
408 | 408 | ||
409 | 409 | ||
410 | -- | Create a perspective projection matrix. | 410 | -- | Create a perspective projection matrix. |
411 | perspective :: Float -- ^ Fovy - Vertical field of view angle in degrees. | 411 | perspective :: Float -- ^ Fovy - Vertical field of view angle in degrees. |
412 | -> Float -- ^ Aspect ratio. | 412 | -> Float -- ^ Aspect ratio. |
413 | -> Float -- ^ Near clip distance. | 413 | -> Float -- ^ Near clip distance. |
414 | -> Float -- ^ Far clip distance | 414 | -> Float -- ^ Far clip distance |
415 | -> Matrix4 | 415 | -> Matrix4 |
416 | perspective fovy r near far = | 416 | perspective fovy r near far = |
417 | let f = 1 / tan (toRAD fovy / 2) | 417 | let f = 1 / tan (toRAD fovy / 2) |
418 | a = near - far | 418 | a = near - far |
419 | in mat4 | 419 | in mat4 |
420 | (f/r) 0 0 0 | 420 | (f/r) 0 0 0 |
421 | 0 f 0 0 | 421 | 0 f 0 0 |
422 | 0 0 ((near+far)/a) (2*near*far/a) | 422 | 0 0 ((near+far)/a) (2*near*far/a) |
423 | 0 0 (-1) 0 | 423 | 0 0 (-1) 0 |
424 | 424 | ||
425 | 425 | ||
426 | -- | Create a plane projection matrix. | 426 | -- | Create a plane projection matrix. |
427 | planeProj :: Vector3 -- ^ Plane normal | 427 | planeProj :: Vector3 -- ^ Plane normal |
428 | -> Float -- ^ Plane distance from the origin | 428 | -> Float -- ^ Plane distance from the origin |
429 | -> Vector3 -- ^ Projection direction | 429 | -> Vector3 -- ^ Projection direction |
430 | -> Matrix4 | 430 | -> Matrix4 |
431 | planeProj n d l = | 431 | planeProj n d l = |
432 | let c = n `dot` l | 432 | let c = n `dot` l |
433 | nx = x n | 433 | nx = x n |
434 | ny = y n | 434 | ny = y n |
435 | nz = z n | 435 | nz = z n |
436 | lx = x l | 436 | lx = x l |
437 | ly = y l | 437 | ly = y l |
438 | lz = z l | 438 | lz = z l |
439 | in mat4 | 439 | in mat4 |
440 | (d + c - nx*lx) (-ny*lx) (-nz*lx) (-lx*d) | 440 | (d + c - nx*lx) (-ny*lx) (-nz*lx) (-lx*d) |
441 | (-nx*ly) (d + c - ny*ly) (-nz*ly) (-ly*d) | 441 | (-nx*ly) (d + c - ny*ly) (-nz*ly) (-ly*d) |
442 | (-nx*lz) (-ny*lz) (d + c - nz*lz) (-lz*d) | 442 | (-nx*lz) (-ny*lz) (d + c - nz*lz) (-lz*d) |
443 | (-nx) (-ny) (-nz) c | 443 | (-nx) (-ny) (-nz) c |
444 | 444 | ||
445 | 445 | ||
446 | -- | Transpose the specified matrix. | 446 | -- | Transpose the specified matrix. |
447 | transpose :: Matrix4 -> Matrix4 | 447 | transpose :: Matrix4 -> Matrix4 |
448 | transpose m = mat4 | 448 | transpose m = mat4 |
449 | (m00 m) (m01 m) (m02 m) (m03 m) | 449 | (m00 m) (m01 m) (m02 m) (m03 m) |
450 | (m10 m) (m11 m) (m12 m) (m13 m) | 450 | (m10 m) (m11 m) (m12 m) (m13 m) |
451 | (m20 m) (m21 m) (m22 m) (m23 m) | 451 | (m20 m) (m21 m) (m22 m) (m23 m) |
452 | (m30 m) (m31 m) (m32 m) (m33 m) | 452 | (m30 m) (m31 m) (m32 m) (m33 m) |
453 | 453 | ||
454 | 454 | ||
455 | -- | Invert the given transformation matrix. | 455 | -- | Invert the given transformation matrix. |
456 | inverseTransform :: Matrix4 -> Matrix4 | 456 | inverseTransform :: Matrix4 -> Matrix4 |
457 | inverseTransform mat = | 457 | inverseTransform mat = |
458 | let | 458 | let |
459 | r = right mat | 459 | r = right mat |
460 | u = up mat | 460 | u = up mat |
461 | f = forward mat | 461 | f = forward mat |
462 | t = position mat | 462 | t = position mat |
463 | in | 463 | in |
464 | mat4 | 464 | mat4 |
465 | (x r) (y r) (z r) (-t `dot` r) | 465 | (x r) (y r) (z r) (-t `dot` r) |
466 | (x u) (y u) (z u) (-t `dot` u) | 466 | (x u) (y u) (z u) (-t `dot` u) |
467 | (x f) (y f) (z f) (-t `dot` f) | 467 | (x f) (y f) (z f) (-t `dot` f) |
468 | 0 0 0 1 | 468 | 0 0 0 1 |
469 | 469 | ||
470 | 470 | ||
471 | -- | Invert the given matrix. | 471 | -- | Invert the given matrix. |
472 | inverse :: Matrix4 -> Matrix4 | 472 | inverse :: Matrix4 -> Matrix4 |
473 | inverse mat = | 473 | inverse mat = |
474 | let | 474 | let |
475 | a00 = m00 mat | 475 | a00 = m00 mat |
476 | a01 = m01 mat | 476 | a01 = m01 mat |
477 | a02 = m02 mat | 477 | a02 = m02 mat |
478 | a03 = m03 mat | 478 | a03 = m03 mat |
479 | a04 = m10 mat | 479 | a04 = m10 mat |
480 | a05 = m11 mat | 480 | a05 = m11 mat |
481 | a06 = m12 mat | 481 | a06 = m12 mat |
482 | a07 = m13 mat | 482 | a07 = m13 mat |
483 | a08 = m20 mat | 483 | a08 = m20 mat |
484 | a09 = m21 mat | 484 | a09 = m21 mat |
485 | a10 = m22 mat | 485 | a10 = m22 mat |
486 | a11 = m23 mat | 486 | a11 = m23 mat |
487 | a12 = m30 mat | 487 | a12 = m30 mat |
488 | a13 = m31 mat | 488 | a13 = m31 mat |
489 | a14 = m32 mat | 489 | a14 = m32 mat |
490 | a15 = m33 mat | 490 | a15 = m33 mat |
491 | 491 | ||
492 | m00' = a05 * a10 * a15 | 492 | m00' = a05 * a10 * a15 |
493 | - a05 * a11 * a14 | 493 | - a05 * a11 * a14 |
494 | - a09 * a06 * a15 | 494 | - a09 * a06 * a15 |
495 | + a09 * a07 * a14 | 495 | + a09 * a07 * a14 |
496 | + a13 * a06 * a11 | 496 | + a13 * a06 * a11 |
497 | - a13 * a07 * a10 | 497 | - a13 * a07 * a10 |
498 | 498 | ||
499 | m04' = -a04 * a10 * a15 | 499 | m04' = -a04 * a10 * a15 |
500 | + a04 * a11 * a14 | 500 | + a04 * a11 * a14 |
501 | + a08 * a06 * a15 | 501 | + a08 * a06 * a15 |
502 | - a08 * a07 * a14 | 502 | - a08 * a07 * a14 |
503 | - a12 * a06 * a11 | 503 | - a12 * a06 * a11 |
504 | + a12 * a07 * a10 | 504 | + a12 * a07 * a10 |
505 | 505 | ||
506 | m08' = a04 * a09 * a15 | 506 | m08' = a04 * a09 * a15 |
507 | - a04 * a11 * a13 | 507 | - a04 * a11 * a13 |
508 | - a08 * a05 * a15 | 508 | - a08 * a05 * a15 |
509 | + a08 * a07 * a13 | 509 | + a08 * a07 * a13 |
510 | + a12 * a05 * a11 | 510 | + a12 * a05 * a11 |
511 | - a12 * a07 * a09 | 511 | - a12 * a07 * a09 |
512 | 512 | ||
513 | m12' = -a04 * a09 * a14 | 513 | m12' = -a04 * a09 * a14 |
514 | + a04 * a10 * a13 | 514 | + a04 * a10 * a13 |
515 | + a08 * a05 * a14 | 515 | + a08 * a05 * a14 |
516 | - a08 * a06 * a13 | 516 | - a08 * a06 * a13 |
517 | - a12 * a05 * a10 | 517 | - a12 * a05 * a10 |
518 | + a12 * a06 * a09 | 518 | + a12 * a06 * a09 |
519 | 519 | ||
520 | m01' = -a01 * a10 * a15 | 520 | m01' = -a01 * a10 * a15 |
521 | + a01 * a11 * a14 | 521 | + a01 * a11 * a14 |
522 | + a09 * a02 * a15 | 522 | + a09 * a02 * a15 |
523 | - a09 * a03 * a14 | 523 | - a09 * a03 * a14 |
524 | - a13 * a02 * a11 | 524 | - a13 * a02 * a11 |
525 | + a13 * a03 * a10 | 525 | + a13 * a03 * a10 |
526 | 526 | ||
527 | m05' = a00 * a10 * a15 | 527 | m05' = a00 * a10 * a15 |
528 | - a00 * a11 * a14 | 528 | - a00 * a11 * a14 |
529 | - a08 * a02 * a15 | 529 | - a08 * a02 * a15 |
530 | + a08 * a03 * a14 | 530 | + a08 * a03 * a14 |
531 | + a12 * a02 * a11 | 531 | + a12 * a02 * a11 |
532 | - a12 * a03 * a10 | 532 | - a12 * a03 * a10 |
533 | 533 | ||
534 | m09' = -a00 * a09 * a15 | 534 | m09' = -a00 * a09 * a15 |
535 | + a00 * a11 * a13 | 535 | + a00 * a11 * a13 |
536 | + a08 * a01 * a15 | 536 | + a08 * a01 * a15 |
537 | - a08 * a03 * a13 | 537 | - a08 * a03 * a13 |
538 | - a12 * a01 * a11 | 538 | - a12 * a01 * a11 |
539 | + a12 * a03 * a09 | 539 | + a12 * a03 * a09 |
540 | 540 | ||
541 | m13' = a00 * a09 * a14 | 541 | m13' = a00 * a09 * a14 |
542 | - a00 * a10 * a13 | 542 | - a00 * a10 * a13 |
543 | - a08 * a01 * a14 | 543 | - a08 * a01 * a14 |
544 | + a08 * a02 * a13 | 544 | + a08 * a02 * a13 |
545 | + a12 * a01 * a10 | 545 | + a12 * a01 * a10 |
546 | - a12 * a02 * a09 | 546 | - a12 * a02 * a09 |
547 | 547 | ||
548 | m02' = a01 * a06 * a15 | 548 | m02' = a01 * a06 * a15 |
549 | - a01 * a07 * a14 | 549 | - a01 * a07 * a14 |
550 | - a05 * a02 * a15 | 550 | - a05 * a02 * a15 |
551 | + a05 * a03 * a14 | 551 | + a05 * a03 * a14 |
552 | + a13 * a02 * a07 | 552 | + a13 * a02 * a07 |
553 | - a13 * a03 * a06 | 553 | - a13 * a03 * a06 |
554 | 554 | ||
555 | m06' = -a00 * a06 * a15 | 555 | m06' = -a00 * a06 * a15 |
556 | + a00 * a07 * a14 | 556 | + a00 * a07 * a14 |
557 | + a04 * a02 * a15 | 557 | + a04 * a02 * a15 |
558 | - a04 * a03 * a14 | 558 | - a04 * a03 * a14 |
559 | - a12 * a02 * a07 | 559 | - a12 * a02 * a07 |
560 | + a12 * a03 * a06 | 560 | + a12 * a03 * a06 |
561 | 561 | ||
562 | m10' = a00 * a05 * a15 | 562 | m10' = a00 * a05 * a15 |
563 | - a00 * a07 * a13 | 563 | - a00 * a07 * a13 |
564 | - a04 * a01 * a15 | 564 | - a04 * a01 * a15 |
565 | + a04 * a03 * a13 | 565 | + a04 * a03 * a13 |
566 | + a12 * a01 * a07 | 566 | + a12 * a01 * a07 |
567 | - a12 * a03 * a05 | 567 | - a12 * a03 * a05 |
568 | 568 | ||
569 | m14' = -a00 * a05 * a14 | 569 | m14' = -a00 * a05 * a14 |
570 | + a00 * a06 * a13 | 570 | + a00 * a06 * a13 |
571 | + a04 * a01 * a14 | 571 | + a04 * a01 * a14 |
572 | - a04 * a02 * a13 | 572 | - a04 * a02 * a13 |
573 | - a12 * a01 * a06 | 573 | - a12 * a01 * a06 |
574 | + a12 * a02 * a05 | 574 | + a12 * a02 * a05 |
575 | 575 | ||
576 | m03' = -a01 * a06 * a11 | 576 | m03' = -a01 * a06 * a11 |
577 | + a01 * a07 * a10 | 577 | + a01 * a07 * a10 |
578 | + a05 * a02 * a11 | 578 | + a05 * a02 * a11 |
579 | - a05 * a03 * a10 | 579 | - a05 * a03 * a10 |
580 | - a09 * a02 * a07 | 580 | - a09 * a02 * a07 |
581 | + a09 * a03 * a06 | 581 | + a09 * a03 * a06 |
582 | 582 | ||
583 | m07' = a00 * a06 * a11 | 583 | m07' = a00 * a06 * a11 |
584 | - a00 * a07 * a10 | 584 | - a00 * a07 * a10 |
585 | - a04 * a02 * a11 | 585 | - a04 * a02 * a11 |
586 | + a04 * a03 * a10 | 586 | + a04 * a03 * a10 |
587 | + a08 * a02 * a07 | 587 | + a08 * a02 * a07 |
588 | - a08 * a03 * a06 | 588 | - a08 * a03 * a06 |
589 | 589 | ||
590 | m11' = -a00 * a05 * a11 | 590 | m11' = -a00 * a05 * a11 |
591 | + a00 * a07 * a09 | 591 | + a00 * a07 * a09 |
592 | + a04 * a01 * a11 | 592 | + a04 * a01 * a11 |
593 | - a04 * a03 * a09 | 593 | - a04 * a03 * a09 |
594 | - a08 * a01 * a07 | 594 | - a08 * a01 * a07 |
595 | + a08 * a03 * a05 | 595 | + a08 * a03 * a05 |
596 | 596 | ||
597 | m15' = a00 * a05 * a10 | 597 | m15' = a00 * a05 * a10 |
598 | - a00 * a06 * a09 | 598 | - a00 * a06 * a09 |
599 | - a04 * a01 * a10 | 599 | - a04 * a01 * a10 |
600 | + a04 * a02 * a09 | 600 | + a04 * a02 * a09 |
601 | + a08 * a01 * a06 | 601 | + a08 * a01 * a06 |
602 | - a08 * a02 * a05 | 602 | - a08 * a02 * a05 |
603 | 603 | ||
604 | det' = a00 * m00' + a01 * m04' + a02 * m08' + a03 * m12' | 604 | det' = a00 * m00' + a01 * m04' + a02 * m08' + a03 * m12' |
605 | in | 605 | in |
606 | if det' == 0 then Spear.Math.Matrix4.id | 606 | if det' == 0 then Spear.Math.Matrix4.id |
607 | else | 607 | else |
608 | let det = 1 / det' | 608 | let det = 1 / det' |
609 | in mat4 | 609 | in mat4 |
610 | (m00' * det) (m04' * det) (m08' * det) (m12' * det) | 610 | (m00' * det) (m04' * det) (m08' * det) (m12' * det) |
611 | (m01' * det) (m05' * det) (m09' * det) (m13' * det) | 611 | (m01' * det) (m05' * det) (m09' * det) (m13' * det) |
612 | (m02' * det) (m06' * det) (m10' * det) (m14' * det) | 612 | (m02' * det) (m06' * det) (m10' * det) (m14' * det) |
613 | (m03' * det) (m07' * det) (m11' * det) (m15' * det) | 613 | (m03' * det) (m07' * det) (m11' * det) (m15' * det) |
614 | 614 | ||
615 | 615 | ||
616 | -- | Transform the given vector in 3D space with the given matrix. | 616 | -- | Transform the given vector in 3D space with the given matrix. |
617 | mul :: Float -> Matrix4 -> Vector3 -> Vector3 | 617 | mul :: Float -> Matrix4 -> Vector3 -> Vector3 |
618 | mul w m v = vec3 x' y' z' | 618 | mul w m v = vec3 x' y' z' |
619 | where | 619 | where |
620 | v' = vec4 (x v) (y v) (z v) w | 620 | v' = vec4 (x v) (y v) (z v) w |
621 | x' = row0 m `dot` v' | 621 | x' = row0 m `dot` v' |
622 | y' = row1 m `dot` v' | 622 | y' = row1 m `dot` v' |
623 | z' = row2 m `dot` v' | 623 | z' = row2 m `dot` v' |
624 | 624 | ||
625 | 625 | ||
626 | -- | Transform the given point vector in 3D space with the given matrix. | 626 | -- | Transform the given point vector in 3D space with the given matrix. |
627 | mulp :: Matrix4 -> Vector3 -> Vector3 | 627 | mulp :: Matrix4 -> Vector3 -> Vector3 |
628 | mulp = mul 1 | 628 | mulp = mul 1 |
629 | 629 | ||
630 | 630 | ||
631 | -- | Transform the given directional vector in 3D space with the given matrix. | 631 | -- | Transform the given directional vector in 3D space with the given matrix. |
632 | muld :: Matrix4 -> Vector3 -> Vector3 | 632 | muld :: Matrix4 -> Vector3 -> Vector3 |
633 | muld = mul 0 | 633 | muld = mul 0 |
634 | 634 | ||
635 | 635 | ||
636 | -- | Transform the given vector with the given matrix. | 636 | -- | Transform the given vector with the given matrix. |
637 | -- | 637 | -- |
638 | -- The vector is brought from homogeneous space to 3D space by performing a | 638 | -- The vector is brought from homogeneous space to 3D space by performing a |
639 | -- perspective divide. | 639 | -- perspective divide. |
640 | mul' :: Float -> Matrix4 -> Vector3 -> Vector3 | 640 | mul' :: Float -> Matrix4 -> Vector3 -> Vector3 |
641 | mul' w m v = vec3 (x'/w') (y'/w') (z'/w') | 641 | mul' w m v = vec3 (x'/w') (y'/w') (z'/w') |
642 | where | 642 | where |
643 | v' = vec4 (x v) (y v) (z v) w | 643 | v' = vec4 (x v) (y v) (z v) w |
644 | x' = row0 m `dot` v' | 644 | x' = row0 m `dot` v' |
645 | y' = row1 m `dot` v' | 645 | y' = row1 m `dot` v' |
646 | z' = row2 m `dot` v' | 646 | z' = row2 m `dot` v' |
647 | w' = row3 m `dot` v' | 647 | w' = row3 m `dot` v' |
648 | 648 | ||
649 | 649 | ||
650 | toRAD = (*pi) . (/180) | 650 | toRAD = (*pi) . (/180) |
diff --git a/Spear/Math/MatrixUtils.hs b/Spear/Math/MatrixUtils.hs index e4273a1..24d9778 100644 --- a/Spear/Math/MatrixUtils.hs +++ b/Spear/Math/MatrixUtils.hs | |||
@@ -1,150 +1,150 @@ | |||
1 | module Spear.Math.MatrixUtils | 1 | module Spear.Math.MatrixUtils |
2 | ( | 2 | ( |
3 | fastNormalMatrix | 3 | fastNormalMatrix |
4 | , unproject | 4 | , unproject |
5 | , rpgUnproject | 5 | , rpgUnproject |
6 | , rpgTransform | 6 | , rpgTransform |
7 | , pltTransform | 7 | , pltTransform |
8 | , rpgInverse | 8 | , rpgInverse |
9 | , pltInverse | 9 | , pltInverse |
10 | , objToClip | 10 | , objToClip |
11 | ) | 11 | ) |
12 | where | 12 | where |
13 | 13 | ||
14 | 14 | ||
15 | import Spear.Math.Camera as Cam | 15 | import Spear.Math.Camera as Cam |
16 | import Spear.Math.Matrix3 as M3 | 16 | import Spear.Math.Matrix3 as M3 |
17 | import Spear.Math.Matrix4 as M4 | 17 | import Spear.Math.Matrix4 as M4 |
18 | import Spear.Math.Spatial3 as S | 18 | import Spear.Math.Spatial3 as S |
19 | import Spear.Math.Vector as V | 19 | import Spear.Math.Vector as V |
20 | 20 | ||
21 | 21 | ||
22 | -- | Compute the normal matrix of the given matrix. | 22 | -- | Compute the normal matrix of the given matrix. |
23 | fastNormalMatrix :: Matrix4 -> Matrix3 | 23 | fastNormalMatrix :: Matrix4 -> Matrix3 |
24 | fastNormalMatrix m = | 24 | fastNormalMatrix m = |
25 | let m' = M4.transpose . M4.inverseTransform $ m | 25 | let m' = M4.transpose . M4.inverseTransform $ m |
26 | in M3.mat3 | 26 | in M3.mat3 |
27 | (M4.m00 m') (M4.m10 m') (M4.m20 m') | 27 | (M4.m00 m') (M4.m10 m') (M4.m20 m') |
28 | (M4.m01 m') (M4.m11 m') (M4.m21 m') | 28 | (M4.m01 m') (M4.m11 m') (M4.m21 m') |
29 | (M4.m02 m') (M4.m12 m') (M4.m22 m') | 29 | (M4.m02 m') (M4.m12 m') (M4.m22 m') |
30 | 30 | ||
31 | 31 | ||
32 | -- | Transform the given point in window coordinates to object coordinates. | 32 | -- | Transform the given point in window coordinates to object coordinates. |
33 | unproject :: Matrix4 -- ^ Inverse projection matrix | 33 | unproject :: Matrix4 -- ^ Inverse projection matrix |
34 | -> Matrix4 -- ^ Inverse modelview matrix. | 34 | -> Matrix4 -- ^ Inverse modelview matrix. |
35 | -> Float -- ^ Viewport x | 35 | -> Float -- ^ Viewport x |
36 | -> Float -- ^ Viewport y | 36 | -> Float -- ^ Viewport y |
37 | -> Float -- ^ Viewport width | 37 | -> Float -- ^ Viewport width |
38 | -> Float -- ^ Viewport height | 38 | -> Float -- ^ Viewport height |
39 | -> Float -- ^ Window x | 39 | -> Float -- ^ Window x |
40 | -> Float -- ^ Window y | 40 | -> Float -- ^ Window y |
41 | -> Float -- ^ Window z | 41 | -> Float -- ^ Window z |
42 | -> Vector3 | 42 | -> Vector3 |
43 | unproject projI modelviewI vpx vpy w h x y z = | 43 | unproject projI modelviewI vpx vpy w h x y z = |
44 | let | 44 | let |
45 | xmouse = 2*(x-vpx)/w - 1 | 45 | xmouse = 2*(x-vpx)/w - 1 |
46 | ymouse = 2*(y-vpy)/h - 1 | 46 | ymouse = 2*(y-vpy)/h - 1 |
47 | zmouse = 2*z - 1 | 47 | zmouse = 2*z - 1 |
48 | in | 48 | in |
49 | (modelviewI * projI) `M4.mulp` vec3 xmouse ymouse zmouse | 49 | (modelviewI * projI) `M4.mulp` vec3 xmouse ymouse zmouse |
50 | 50 | ||
51 | 51 | ||
52 | -- | Transform the given point in window coordinates to 2d coordinates. | 52 | -- | Transform the given point in window coordinates to 2d coordinates. |
53 | -- | 53 | -- |
54 | -- The line defined by the given point in window space is intersected with | 54 | -- The line defined by the given point in window space is intersected with |
55 | -- the XZ plane in world space to yield the resulting 2d point. | 55 | -- the XZ plane in world space to yield the resulting 2d point. |
56 | rpgUnproject | 56 | rpgUnproject |
57 | :: Matrix4 -- ^ Inverse projection matrix | 57 | :: Matrix4 -- ^ Inverse projection matrix |
58 | -> Matrix4 -- ^ Inverse viewI matrix. | 58 | -> Matrix4 -- ^ Inverse viewI matrix. |
59 | -> Float -- ^ Viewport x | 59 | -> Float -- ^ Viewport x |
60 | -> Float -- ^ Viewport y | 60 | -> Float -- ^ Viewport y |
61 | -> Float -- ^ Viewport width | 61 | -> Float -- ^ Viewport width |
62 | -> Float -- ^ Viewport height | 62 | -> Float -- ^ Viewport height |
63 | -> Float -- ^ Window x | 63 | -> Float -- ^ Window x |
64 | -> Float -- ^ Window y | 64 | -> Float -- ^ Window y |
65 | -> Vector2 | 65 | -> Vector2 |
66 | rpgUnproject projI viewI vpx vpy w h wx wy = | 66 | rpgUnproject projI viewI vpx vpy w h wx wy = |
67 | let | 67 | let |
68 | p1 = unproject projI viewI vpx vpy w h wx wy 0 | 68 | p1 = unproject projI viewI vpx vpy w h wx wy 0 |
69 | p2 = unproject projI viewI vpx vpy w h wx wy (-1) | 69 | p2 = unproject projI viewI vpx vpy w h wx wy (-1) |
70 | lambda = (y p1 / (y p1 - y p2)) | 70 | lambda = (y p1 / (y p1 - y p2)) |
71 | p' = p1 + V.scale lambda (p2 - p1) | 71 | p' = p1 + V.scale lambda (p2 - p1) |
72 | in | 72 | in |
73 | vec2 (x p') (-(z p')) | 73 | vec2 (x p') (-(z p')) |
74 | 74 | ||
75 | 75 | ||
76 | -- | Map an object's transform in view space to world space. | 76 | -- | Map an object's transform in view space to world space. |
77 | rpgTransform | 77 | rpgTransform |
78 | :: Float -- ^ The height above the ground | 78 | :: Float -- ^ The height above the ground |
79 | -> Float -- ^ Angle of rotation | 79 | -> Float -- ^ Angle of rotation |
80 | -> Vector3 -- ^ Axis of rotation | 80 | -> Vector3 -- ^ Axis of rotation |
81 | -> Vector2 -- ^ Object's position | 81 | -> Vector2 -- ^ Object's position |
82 | -> Matrix4 -- ^ Inverse view matrix | 82 | -> Matrix4 -- ^ Inverse view matrix |
83 | -> Matrix4 | 83 | -> Matrix4 |
84 | rpgTransform h a axis pos viewI = | 84 | rpgTransform h a axis pos viewI = |
85 | let p1 = viewI `M4.mulp` (vec3 (x pos) (y pos) 0) | 85 | let p1 = viewI `M4.mulp` (vec3 (x pos) (y pos) 0) |
86 | p2 = viewI `M4.mulp` (vec3 (x pos) (y pos) (-1)) | 86 | p2 = viewI `M4.mulp` (vec3 (x pos) (y pos) (-1)) |
87 | lambda = (y p1 / (y p1 - y p2)) | 87 | lambda = (y p1 / (y p1 - y p2)) |
88 | p = p1 + V.scale lambda (p2 - p1) | 88 | p = p1 + V.scale lambda (p2 - p1) |
89 | mat' = axisAngle axis a | 89 | mat' = axisAngle axis a |
90 | r = M4.right mat' | 90 | r = M4.right mat' |
91 | u = M4.up mat' | 91 | u = M4.up mat' |
92 | f = M4.forward mat' | 92 | f = M4.forward mat' |
93 | t = p + vec3 0 h 0 | 93 | t = p + vec3 0 h 0 |
94 | in mat4 | 94 | in mat4 |
95 | (x r) (x u) (x f) (x t) | 95 | (x r) (x u) (x f) (x t) |
96 | (y r) (y u) (y f) (y t) | 96 | (y r) (y u) (y f) (y t) |
97 | (z r) (z u) (z f) (z t) | 97 | (z r) (z u) (z f) (z t) |
98 | 0 0 0 1 | 98 | 0 0 0 1 |
99 | 99 | ||
100 | 100 | ||
101 | -- | Map an object's transform in view space to world space. | 101 | -- | Map an object's transform in view space to world space. |
102 | pltTransform :: Matrix3 -> Matrix4 | 102 | pltTransform :: Matrix3 -> Matrix4 |
103 | pltTransform mat = | 103 | pltTransform mat = |
104 | let r = let r' = M3.right mat in vec3 (x r') (y r') 0 | 104 | let r = let r' = M3.right mat in vec3 (x r') (y r') 0 |
105 | u = let u' = M3.up mat in vec3 (x u') (y u') 0 | 105 | u = let u' = M3.up mat in vec3 (x u') (y u') 0 |
106 | f = unitz3 | 106 | f = unitz3 |
107 | t = let t' = M3.position mat in vec3 (x t') (y t') 0 | 107 | t = let t' = M3.position mat in vec3 (x t') (y t') 0 |
108 | in mat4 | 108 | in mat4 |
109 | (x r) (x u) (x f) (x t) | 109 | (x r) (x u) (x f) (x t) |
110 | (y r) (y u) (y f) (y t) | 110 | (y r) (y u) (y f) (y t) |
111 | (z r) (z u) (z f) (z t) | 111 | (z r) (z u) (z f) (z t) |
112 | 0 0 0 1 | 112 | 0 0 0 1 |
113 | 113 | ||
114 | 114 | ||
115 | -- | Map an object's transform in world space to view space. | 115 | -- | Map an object's transform in world space to view space. |
116 | -- | 116 | -- |
117 | -- The XY plane in 2D translates to the X(-Z) plane in 3D. | 117 | -- The XY plane in 2D translates to the X(-Z) plane in 3D. |
118 | -- | 118 | -- |
119 | -- Use this in games such as RPGs and RTSs. | 119 | -- Use this in games such as RPGs and RTSs. |
120 | rpgInverse | 120 | rpgInverse |
121 | :: Float -- ^ The height above the ground | 121 | :: Float -- ^ The height above the ground |
122 | -> Float -- ^ Angle of rotation | 122 | -> Float -- ^ Angle of rotation |
123 | -> Vector3 -- ^ Axis of rotation | 123 | -> Vector3 -- ^ Axis of rotation |
124 | -> Vector2 -- ^ Object's position | 124 | -> Vector2 -- ^ Object's position |
125 | -> Matrix4 -- ^ Inverse view matrix | 125 | -> Matrix4 -- ^ Inverse view matrix |
126 | -> Matrix4 | 126 | -> Matrix4 |
127 | rpgInverse h a axis pos viewI = | 127 | rpgInverse h a axis pos viewI = |
128 | M4.inverseTransform $ rpgTransform h a axis pos viewI | 128 | M4.inverseTransform $ rpgTransform h a axis pos viewI |
129 | 129 | ||
130 | 130 | ||
131 | -- | Map an object's transform in world space to view space. | 131 | -- | Map an object's transform in world space to view space. |
132 | -- | 132 | -- |
133 | -- This function maps an object's transform in 2D to the object's inverse in 3D. | 133 | -- This function maps an object's transform in 2D to the object's inverse in 3D. |
134 | -- | 134 | -- |
135 | -- The XY plane in 2D translates to the XY plane in 3D. | 135 | -- The XY plane in 2D translates to the XY plane in 3D. |
136 | -- | 136 | -- |
137 | -- Use this in games like platformers and space invaders style games. | 137 | -- Use this in games like platformers and space invaders style games. |
138 | pltInverse :: Matrix3 -> Matrix4 | 138 | pltInverse :: Matrix3 -> Matrix4 |
139 | pltInverse = M4.inverseTransform . pltTransform | 139 | pltInverse = M4.inverseTransform . pltTransform |
140 | 140 | ||
141 | 141 | ||
142 | -- | Transform an object from object to clip space coordinates. | 142 | -- | Transform an object from object to clip space coordinates. |
143 | objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 | 143 | objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 |
144 | objToClip cam model p = | 144 | objToClip cam model p = |
145 | let | 145 | let |
146 | view = M4.inverseTransform $ S.transform cam | 146 | view = M4.inverseTransform $ S.transform cam |
147 | proj = Cam.projection cam | 147 | proj = Cam.projection cam |
148 | p' = (proj * view * model) `M4.mulp` p | 148 | p' = (proj * view * model) `M4.mulp` p |
149 | in | 149 | in |
150 | vec2 (x p') (y p') | 150 | vec2 (x p') (y p') |
diff --git a/Spear/Math/Octree.hs b/Spear/Math/Octree.hs index f5538b4..6c22468 100644 --- a/Spear/Math/Octree.hs +++ b/Spear/Math/Octree.hs | |||
@@ -1,228 +1,228 @@ | |||
1 | module Spear.Math.Octree | 1 | module Spear.Math.Octree |
2 | ( | 2 | ( |
3 | Octree | 3 | Octree |
4 | , makeOctree | 4 | , makeOctree |
5 | , clone | 5 | , clone |
6 | , Spear.Math.Octree.insert | 6 | , Spear.Math.Octree.insert |
7 | , Spear.Math.Octree.map | 7 | , Spear.Math.Octree.map |
8 | , gmap | 8 | , gmap |
9 | ) | 9 | ) |
10 | where | 10 | where |
11 | 11 | ||
12 | import Spear.Math.AABB | 12 | import Spear.Math.AABB |
13 | import Spear.Math.Collision | 13 | import Spear.Math.Collision |
14 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
15 | 15 | ||
16 | import Control.Applicative ((<*>)) | 16 | import Control.Applicative ((<*>)) |
17 | import Data.List | 17 | import Data.List |
18 | import Data.Functor | 18 | import Data.Functor |
19 | import Data.Monoid | 19 | import Data.Monoid |
20 | import qualified Data.Foldable as F | 20 | import qualified Data.Foldable as F |
21 | 21 | ||
22 | -- | An octree. | 22 | -- | An octree. |
23 | data Octree e | 23 | data Octree e |
24 | = Octree | 24 | = Octree |
25 | { root :: !AABB2 | 25 | { root :: !AABB2 |
26 | , ents :: ![e] | 26 | , ents :: ![e] |
27 | , c1 :: !(Octree e) | 27 | , c1 :: !(Octree e) |
28 | , c2 :: !(Octree e) | 28 | , c2 :: !(Octree e) |
29 | , c3 :: !(Octree e) | 29 | , c3 :: !(Octree e) |
30 | , c4 :: !(Octree e) | 30 | , c4 :: !(Octree e) |
31 | , c5 :: !(Octree e) | 31 | , c5 :: !(Octree e) |
32 | , c6 :: !(Octree e) | 32 | , c6 :: !(Octree e) |
33 | , c7 :: !(Octree e) | 33 | , c7 :: !(Octree e) |
34 | , c8 :: !(Octree e) | 34 | , c8 :: !(Octree e) |
35 | } | 35 | } |
36 | | | 36 | | |
37 | Leaf | 37 | Leaf |
38 | { root :: !AABB2 | 38 | { root :: !AABB2 |
39 | , ents :: ![e] | 39 | , ents :: ![e] |
40 | } | 40 | } |
41 | 41 | ||
42 | -- | Construct an octree using the specified AABB as the root and having the specified depth. | 42 | -- | Construct an octree using the specified AABB as the root and having the specified depth. |
43 | makeOctree :: Int -> AABB2 -> Octree e | 43 | makeOctree :: Int -> AABB2 -> Octree e |
44 | makeOctree d root@(AABB2 min max) | 44 | makeOctree d root@(AABB2 min max) |
45 | | d == 0 = Leaf root [] | 45 | | d == 0 = Leaf root [] |
46 | | otherwise = Octree root [] c1 c2 c3 c4 c5 c6 c7 c8 | 46 | | otherwise = Octree root [] c1 c2 c3 c4 c5 c6 c7 c8 |
47 | where | 47 | where |
48 | boxes = subdivide root | 48 | boxes = subdivide root |
49 | c1 = makeOctree (d-1) $ boxes !! 0 | 49 | c1 = makeOctree (d-1) $ boxes !! 0 |
50 | c2 = makeOctree (d-1) $ boxes !! 1 | 50 | c2 = makeOctree (d-1) $ boxes !! 1 |
51 | c3 = makeOctree (d-1) $ boxes !! 2 | 51 | c3 = makeOctree (d-1) $ boxes !! 2 |
52 | c4 = makeOctree (d-1) $ boxes !! 3 | 52 | c4 = makeOctree (d-1) $ boxes !! 3 |
53 | c5 = makeOctree (d-1) $ boxes !! 4 | 53 | c5 = makeOctree (d-1) $ boxes !! 4 |
54 | c6 = makeOctree (d-1) $ boxes !! 5 | 54 | c6 = makeOctree (d-1) $ boxes !! 5 |
55 | c7 = makeOctree (d-1) $ boxes !! 6 | 55 | c7 = makeOctree (d-1) $ boxes !! 6 |
56 | c8 = makeOctree (d-1) $ boxes !! 7 | 56 | c8 = makeOctree (d-1) $ boxes !! 7 |
57 | 57 | ||
58 | subdivide :: AABB2 -> [AABB2] | 58 | subdivide :: AABB2 -> [AABB2] |
59 | subdivide (AABB2 min max) = [a1, a2, a3, a4, a5, a6, a7, a8] | 59 | subdivide (AABB2 min max) = [a1, a2, a3, a4, a5, a6, a7, a8] |
60 | where | 60 | where |
61 | v = (max-min) / 2 | 61 | v = (max-min) / 2 |
62 | c = vec2 (x min + x v) (y min + y v) | 62 | c = vec2 (x min + x v) (y min + y v) |
63 | a1 = AABB2 min c | 63 | a1 = AABB2 min c |
64 | a2 = AABB2 ( vec2 (x min) (y min)) ( vec2 (x c) (y c) ) | 64 | a2 = AABB2 ( vec2 (x min) (y min)) ( vec2 (x c) (y c) ) |
65 | a3 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) | 65 | a3 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) |
66 | a4 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) | 66 | a4 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) |
67 | a5 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) | 67 | a5 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) |
68 | a6 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) | 68 | a6 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) |
69 | a7 = AABB2 ( vec2 (x c) (y c) ) ( vec2 (x max) (y max)) | 69 | a7 = AABB2 ( vec2 (x c) (y c) ) ( vec2 (x max) (y max)) |
70 | a8 = AABB2 c max | 70 | a8 = AABB2 c max |
71 | 71 | ||
72 | -- | Clone the structure of the octree. The new octree has no entities. | 72 | -- | Clone the structure of the octree. The new octree has no entities. |
73 | clone :: Octree e -> Octree e | 73 | clone :: Octree e -> Octree e |
74 | clone (Leaf root ents) = Leaf root [] | 74 | clone (Leaf root ents) = Leaf root [] |
75 | clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8' | 75 | clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8' |
76 | where | 76 | where |
77 | c1' = clone c1 | 77 | c1' = clone c1 |
78 | c2' = clone c2 | 78 | c2' = clone c2 |
79 | c3' = clone c3 | 79 | c3' = clone c3 |
80 | c4' = clone c4 | 80 | c4' = clone c4 |
81 | c5' = clone c5 | 81 | c5' = clone c5 |
82 | c6' = clone c6 | 82 | c6' = clone c6 |
83 | c7' = clone c7 | 83 | c7' = clone c7 |
84 | c8' = clone c8 | 84 | c8' = clone c8 |
85 | 85 | ||
86 | keep :: (e -> AABB2 -> CollisionType) -> AABB2 -> e -> Bool | 86 | keep :: (e -> AABB2 -> CollisionType) -> AABB2 -> e -> Bool |
87 | keep testAABB2 aabb e = test == FullyContainedBy | 87 | keep testAABB2 aabb e = test == FullyContainedBy |
88 | where test = e `testAABB2` aabb | 88 | where test = e `testAABB2` aabb |
89 | 89 | ||
90 | -- | Insert a list of entities into the octree. | 90 | -- | Insert a list of entities into the octree. |
91 | insert :: (e -> AABB2 -> CollisionType) -> Octree e -> [e] -> Octree e | 91 | insert :: (e -> AABB2 -> CollisionType) -> Octree e -> [e] -> Octree e |
92 | insert testAABB2 octree es = octree' where (octree', _) = insert' testAABB2 es octree | 92 | insert testAABB2 octree es = octree' where (octree', _) = insert' testAABB2 es octree |
93 | 93 | ||
94 | insert' :: (e -> AABB2 -> CollisionType) -> [e] -> Octree e -> (Octree e, [e]) | 94 | insert' :: (e -> AABB2 -> CollisionType) -> [e] -> Octree e -> (Octree e, [e]) |
95 | 95 | ||
96 | insert' testAABB2 es (Leaf root ents) = (Leaf root ents', outliers) | 96 | insert' testAABB2 es (Leaf root ents) = (Leaf root ents', outliers) |
97 | where | 97 | where |
98 | ents' = ents ++ ents_kept | 98 | ents' = ents ++ ents_kept |
99 | ents_kept = filter (keep testAABB2 root) es | 99 | ents_kept = filter (keep testAABB2 root) es |
100 | outliers = filter (not . keep testAABB2 root) es | 100 | outliers = filter (not . keep testAABB2 root) es |
101 | 101 | ||
102 | insert' testAABB2 es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = | 102 | insert' testAABB2 es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = |
103 | (Octree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers) | 103 | (Octree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers) |
104 | where | 104 | where |
105 | ents' = ents ++ ents_kept | 105 | ents' = ents ++ ents_kept |
106 | new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 | 106 | new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 |
107 | ents_kept = filter (keep testAABB2 root) new_ents | 107 | ents_kept = filter (keep testAABB2 root) new_ents |
108 | outliers = filter (not . keep testAABB2 root) new_ents | 108 | outliers = filter (not . keep testAABB2 root) new_ents |
109 | (c1', ents1) = insert' testAABB2 es c1 | 109 | (c1', ents1) = insert' testAABB2 es c1 |
110 | (c2', ents2) = insert' testAABB2 es c2 | 110 | (c2', ents2) = insert' testAABB2 es c2 |
111 | (c3', ents3) = insert' testAABB2 es c3 | 111 | (c3', ents3) = insert' testAABB2 es c3 |
112 | (c4', ents4) = insert' testAABB2 es c4 | 112 | (c4', ents4) = insert' testAABB2 es c4 |
113 | (c5', ents5) = insert' testAABB2 es c5 | 113 | (c5', ents5) = insert' testAABB2 es c5 |
114 | (c6', ents6) = insert' testAABB2 es c6 | 114 | (c6', ents6) = insert' testAABB2 es c6 |
115 | (c7', ents7) = insert' testAABB2 es c7 | 115 | (c7', ents7) = insert' testAABB2 es c7 |
116 | (c8', ents8) = insert' testAABB2 es c8 | 116 | (c8', ents8) = insert' testAABB2 es c8 |
117 | 117 | ||
118 | -- | Extract all entities from the octree. The resulting octree has no entities. | 118 | -- | Extract all entities from the octree. The resulting octree has no entities. |
119 | extract :: Octree e -> (Octree e, [e]) | 119 | extract :: Octree e -> (Octree e, [e]) |
120 | extract (Leaf root ents) = (Leaf root [], ents) | 120 | extract (Leaf root ents) = (Leaf root [], ents) |
121 | extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents') | 121 | extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents') |
122 | where | 122 | where |
123 | (c1', ents1) = extract c1 | 123 | (c1', ents1) = extract c1 |
124 | (c2', ents2) = extract c2 | 124 | (c2', ents2) = extract c2 |
125 | (c3', ents3) = extract c3 | 125 | (c3', ents3) = extract c3 |
126 | (c4', ents4) = extract c4 | 126 | (c4', ents4) = extract c4 |
127 | (c5', ents5) = extract c5 | 127 | (c5', ents5) = extract c5 |
128 | (c6', ents6) = extract c6 | 128 | (c6', ents6) = extract c6 |
129 | (c7', ents7) = extract c7 | 129 | (c7', ents7) = extract c7 |
130 | (c8', ents8) = extract c8 | 130 | (c8', ents8) = extract c8 |
131 | ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 | 131 | ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 |
132 | 132 | ||
133 | -- | Apply the given function to the entities in the octree. | 133 | -- | Apply the given function to the entities in the octree. |
134 | -- | 134 | -- |
135 | -- Entities that break out of their cell are reallocated appropriately. | 135 | -- Entities that break out of their cell are reallocated appropriately. |
136 | map :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> Octree e | 136 | map :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> Octree e |
137 | map testAABB2 f o = | 137 | map testAABB2 f o = |
138 | let (o', outliers) = map' testAABB2 f o | 138 | let (o', outliers) = map' testAABB2 f o |
139 | in Spear.Math.Octree.insert testAABB2 o' outliers | 139 | in Spear.Math.Octree.insert testAABB2 o' outliers |
140 | 140 | ||
141 | map' :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e]) | 141 | map' :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e]) |
142 | 142 | ||
143 | map' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) | 143 | map' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) |
144 | where | 144 | where |
145 | ents' = fmap f ents | 145 | ents' = fmap f ents |
146 | ents_kept = filter (keep testAABB2 root) ents' | 146 | ents_kept = filter (keep testAABB2 root) ents' |
147 | outliers = filter (not . keep testAABB2 root) ents' | 147 | outliers = filter (not . keep testAABB2 root) ents' |
148 | 148 | ||
149 | map' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = | 149 | map' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = |
150 | (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) | 150 | (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) |
151 | where | 151 | where |
152 | ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 | 152 | ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 |
153 | ents_kept = filter (keep testAABB2 root) ents' | 153 | ents_kept = filter (keep testAABB2 root) ents' |
154 | outliers = filter (not . keep testAABB2 root) ents' | 154 | outliers = filter (not . keep testAABB2 root) ents' |
155 | (c1', out1) = map' testAABB2 f c1 | 155 | (c1', out1) = map' testAABB2 f c1 |
156 | (c2', out2) = map' testAABB2 f c2 | 156 | (c2', out2) = map' testAABB2 f c2 |
157 | (c3', out3) = map' testAABB2 f c3 | 157 | (c3', out3) = map' testAABB2 f c3 |
158 | (c4', out4) = map' testAABB2 f c4 | 158 | (c4', out4) = map' testAABB2 f c4 |
159 | (c5', out5) = map' testAABB2 f c5 | 159 | (c5', out5) = map' testAABB2 f c5 |
160 | (c6', out6) = map' testAABB2 f c6 | 160 | (c6', out6) = map' testAABB2 f c6 |
161 | (c7', out7) = map' testAABB2 f c7 | 161 | (c7', out7) = map' testAABB2 f c7 |
162 | (c8', out8) = map' testAABB2 f c8 | 162 | (c8', out8) = map' testAABB2 f c8 |
163 | 163 | ||
164 | 164 | ||
165 | -- | Apply a function to the entity groups in the octree. | 165 | -- | Apply a function to the entity groups in the octree. |
166 | -- | 166 | -- |
167 | -- Entities that break out of their cell are reallocated appropriately. | 167 | -- Entities that break out of their cell are reallocated appropriately. |
168 | gmap :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e | 168 | gmap :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e |
169 | gmap testAABB2 f o = | 169 | gmap testAABB2 f o = |
170 | let (o', outliers) = gmap' testAABB2 f o | 170 | let (o', outliers) = gmap' testAABB2 f o |
171 | in Spear.Math.Octree.insert testAABB2 o' outliers | 171 | in Spear.Math.Octree.insert testAABB2 o' outliers |
172 | 172 | ||
173 | gmap' :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e]) | 173 | gmap' :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e]) |
174 | 174 | ||
175 | gmap' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) | 175 | gmap' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) |
176 | where | 176 | where |
177 | ents' = f <$> ents <*> ents | 177 | ents' = f <$> ents <*> ents |
178 | ents_kept = filter (keep testAABB2 root) ents' | 178 | ents_kept = filter (keep testAABB2 root) ents' |
179 | outliers = filter (not . keep testAABB2 root) ents' | 179 | outliers = filter (not . keep testAABB2 root) ents' |
180 | 180 | ||
181 | gmap' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = | 181 | gmap' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = |
182 | (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) | 182 | (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) |
183 | where | 183 | where |
184 | ents'= (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 | 184 | ents'= (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 |
185 | ents_kept = filter (keep testAABB2 root) ents' | 185 | ents_kept = filter (keep testAABB2 root) ents' |
186 | outliers = filter (not . keep testAABB2 root) ents' | 186 | outliers = filter (not . keep testAABB2 root) ents' |
187 | (c1', out1) = gmap' testAABB2 f c1 | 187 | (c1', out1) = gmap' testAABB2 f c1 |
188 | (c2', out2) = gmap' testAABB2 f c2 | 188 | (c2', out2) = gmap' testAABB2 f c2 |
189 | (c3', out3) = gmap' testAABB2 f c3 | 189 | (c3', out3) = gmap' testAABB2 f c3 |
190 | (c4', out4) = gmap' testAABB2 f c4 | 190 | (c4', out4) = gmap' testAABB2 f c4 |
191 | (c5', out5) = gmap' testAABB2 f c5 | 191 | (c5', out5) = gmap' testAABB2 f c5 |
192 | (c6', out6) = gmap' testAABB2 f c6 | 192 | (c6', out6) = gmap' testAABB2 f c6 |
193 | (c7', out7) = gmap' testAABB2 f c7 | 193 | (c7', out7) = gmap' testAABB2 f c7 |
194 | (c8', out8) = gmap' testAABB2 f c8 | 194 | (c8', out8) = gmap' testAABB2 f c8 |
195 | 195 | ||
196 | instance Functor Octree where | 196 | instance Functor Octree where |
197 | 197 | ||
198 | fmap f (Leaf root ents) = Leaf root $ fmap f ents | 198 | fmap f (Leaf root ents) = Leaf root $ fmap f ents |
199 | 199 | ||
200 | fmap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = | 200 | fmap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = |
201 | Octree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8' | 201 | Octree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8' |
202 | where | 202 | where |
203 | c1' = fmap f c1 | 203 | c1' = fmap f c1 |
204 | c2' = fmap f c2 | 204 | c2' = fmap f c2 |
205 | c3' = fmap f c3 | 205 | c3' = fmap f c3 |
206 | c4' = fmap f c4 | 206 | c4' = fmap f c4 |
207 | c5' = fmap f c5 | 207 | c5' = fmap f c5 |
208 | c6' = fmap f c6 | 208 | c6' = fmap f c6 |
209 | c7' = fmap f c7 | 209 | c7' = fmap f c7 |
210 | c8' = fmap f c8 | 210 | c8' = fmap f c8 |
211 | 211 | ||
212 | instance F.Foldable Octree where | 212 | instance F.Foldable Octree where |
213 | 213 | ||
214 | foldMap f (Leaf root ents) = mconcat . fmap f $ ents | 214 | foldMap f (Leaf root ents) = mconcat . fmap f $ ents |
215 | 215 | ||
216 | foldMap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = | 216 | foldMap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = |
217 | mconcat (fmap f ents) `mappend` | 217 | mconcat (fmap f ents) `mappend` |
218 | c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend` | 218 | c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend` |
219 | c5' `mappend` c6' `mappend` c7' `mappend` c8' | 219 | c5' `mappend` c6' `mappend` c7' `mappend` c8' |
220 | where | 220 | where |
221 | c1' = F.foldMap f c1 | 221 | c1' = F.foldMap f c1 |
222 | c2' = F.foldMap f c2 | 222 | c2' = F.foldMap f c2 |
223 | c3' = F.foldMap f c3 | 223 | c3' = F.foldMap f c3 |
224 | c4' = F.foldMap f c4 | 224 | c4' = F.foldMap f c4 |
225 | c5' = F.foldMap f c5 | 225 | c5' = F.foldMap f c5 |
226 | c6' = F.foldMap f c6 | 226 | c6' = F.foldMap f c6 |
227 | c7' = F.foldMap f c7 | 227 | c7' = F.foldMap f c7 |
228 | c8' = F.foldMap f c8 | 228 | c8' = F.foldMap f c8 |
diff --git a/Spear/Math/Physics.hs b/Spear/Math/Physics.hs index f24139b..ad3bad1 100644 --- a/Spear/Math/Physics.hs +++ b/Spear/Math/Physics.hs | |||
@@ -1,9 +1,9 @@ | |||
1 | module Spear.Math.Physics | 1 | module Spear.Math.Physics |
2 | ( | 2 | ( |
3 | module Spear.Math.Physics.Rigid | 3 | module Spear.Math.Physics.Rigid |
4 | , module Spear.Math.Physics.Types | 4 | , module Spear.Math.Physics.Types |
5 | ) | 5 | ) |
6 | where | 6 | where |
7 | 7 | ||
8 | import Spear.Math.Physics.Rigid | 8 | import Spear.Math.Physics.Rigid |
9 | import Spear.Math.Physics.Types | 9 | import Spear.Math.Physics.Types |
diff --git a/Spear/Math/Physics/Rigid.hs b/Spear/Math/Physics/Rigid.hs index 198385e..28995bd 100644 --- a/Spear/Math/Physics/Rigid.hs +++ b/Spear/Math/Physics/Rigid.hs | |||
@@ -1,125 +1,125 @@ | |||
1 | module Spear.Math.Physics.Rigid | 1 | module Spear.Math.Physics.Rigid |
2 | ( | 2 | ( |
3 | module Spear.Math.Physics.Types | 3 | module Spear.Math.Physics.Types |
4 | , RigidBody(..) | 4 | , RigidBody(..) |
5 | , rigidBody | 5 | , rigidBody |
6 | , update | 6 | , update |
7 | , setVelocity | 7 | , setVelocity |
8 | , setAcceleration | 8 | , setAcceleration |
9 | ) | 9 | ) |
10 | where | 10 | where |
11 | 11 | ||
12 | import qualified Spear.Math.Matrix3 as M3 | 12 | import qualified Spear.Math.Matrix3 as M3 |
13 | import Spear.Math.Spatial2 | 13 | import Spear.Math.Spatial2 |
14 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
15 | import Spear.Physics.Types | 15 | import Spear.Physics.Types |
16 | 16 | ||
17 | import Data.List (foldl') | 17 | import Data.List (foldl') |
18 | import Control.Monad.State | 18 | import Control.Monad.State |
19 | 19 | ||
20 | data RigidBody = RigidBody | 20 | data RigidBody = RigidBody |
21 | { mass :: {-# UNPACK #-} !Float | 21 | { mass :: {-# UNPACK #-} !Float |
22 | , position :: {-# UNPACK #-} !Position | 22 | , position :: {-# UNPACK #-} !Position |
23 | , velocity :: {-# UNPACK #-} !Velocity | 23 | , velocity :: {-# UNPACK #-} !Velocity |
24 | , acceleration :: {-# UNPACK #-} !Acceleration | 24 | , acceleration :: {-# UNPACK #-} !Acceleration |
25 | } | 25 | } |
26 | 26 | ||
27 | instance Spatial2 RigidBody where | 27 | instance Spatial2 RigidBody where |
28 | 28 | ||
29 | move v body = body { position = v + position body } | 29 | move v body = body { position = v + position body } |
30 | 30 | ||
31 | moveFwd speed body = body { position = position body + scale speed unity2 } | 31 | moveFwd speed body = body { position = position body + scale speed unity2 } |
32 | 32 | ||
33 | moveBack speed body = body { position = position body + scale (-speed) unity2 } | 33 | moveBack speed body = body { position = position body + scale (-speed) unity2 } |
34 | 34 | ||
35 | strafeLeft speed body = body { position = position body + scale (-speed) unitx2 } | 35 | strafeLeft speed body = body { position = position body + scale (-speed) unitx2 } |
36 | 36 | ||
37 | strafeRight speed body = body { position = position body + scale speed unitx2 } | 37 | strafeRight speed body = body { position = position body + scale speed unitx2 } |
38 | 38 | ||
39 | rotate angle = id | 39 | rotate angle = id |
40 | 40 | ||
41 | setRotation angle = id | 41 | setRotation angle = id |
42 | 42 | ||
43 | pos = position | 43 | pos = position |
44 | 44 | ||
45 | fwd _ = unity2 | 45 | fwd _ = unity2 |
46 | 46 | ||
47 | up _ = unity2 | 47 | up _ = unity2 |
48 | 48 | ||
49 | right _ = unitx2 | 49 | right _ = unitx2 |
50 | 50 | ||
51 | transform body = M3.transform unitx2 unity2 $ position body | 51 | transform body = M3.transform unitx2 unity2 $ position body |
52 | 52 | ||
53 | setTransform transf body = body { position = M3.position transf } | 53 | setTransform transf body = body { position = M3.position transf } |
54 | 54 | ||
55 | setPos p body = body { position = p } | 55 | setPos p body = body { position = p } |
56 | 56 | ||
57 | -- | Build a 'RigidBody'. | 57 | -- | Build a 'RigidBody'. |
58 | rigidBody :: Mass -> Position -> RigidBody | 58 | rigidBody :: Mass -> Position -> RigidBody |
59 | rigidBody m x = RigidBody m x zero2 zero2 | 59 | rigidBody m x = RigidBody m x zero2 zero2 |
60 | 60 | ||
61 | -- | Update the given 'RigidBody'. | 61 | -- | Update the given 'RigidBody'. |
62 | update :: [Force] -> Dt -> RigidBody -> RigidBody | 62 | update :: [Force] -> Dt -> RigidBody -> RigidBody |
63 | update forces dt body = | 63 | update forces dt body = |
64 | let netforce = foldl' (+) zero2 forces | 64 | let netforce = foldl' (+) zero2 forces |
65 | m = mass body | 65 | m = mass body |
66 | r1 = position body | 66 | r1 = position body |
67 | v1 = velocity body | 67 | v1 = velocity body |
68 | a1 = acceleration body | 68 | a1 = acceleration body |
69 | r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1 | 69 | r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1 |
70 | v' = v1 + scale (0.5*dt) a1 | 70 | v' = v1 + scale (0.5*dt) a1 |
71 | a2 = a1 + scale (1/m) netforce | 71 | a2 = a1 + scale (1/m) netforce |
72 | v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2 | 72 | v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2 |
73 | in | 73 | in |
74 | RigidBody m r2 v2 a2 | 74 | RigidBody m r2 v2 a2 |
75 | 75 | ||
76 | -- | Set the body's velocity. | 76 | -- | Set the body's velocity. |
77 | setVelocity :: Velocity -> RigidBody -> RigidBody | 77 | setVelocity :: Velocity -> RigidBody -> RigidBody |
78 | setVelocity v body = body { velocity = v } | 78 | setVelocity v body = body { velocity = v } |
79 | 79 | ||
80 | -- | Set the body's acceleration. | 80 | -- | Set the body's acceleration. |
81 | setAcceleration :: Acceleration -> RigidBody -> RigidBody | 81 | setAcceleration :: Acceleration -> RigidBody -> RigidBody |
82 | setAcceleration a body = body { acceleration = a } | 82 | setAcceleration a body = body { acceleration = a } |
83 | 83 | ||
84 | 84 | ||
85 | -- test | 85 | -- test |
86 | {-gravity = vec2 0 (-10) | 86 | {-gravity = vec2 0 (-10) |
87 | b0 = rigidBody 50 $ vec2 0 1000 | 87 | b0 = rigidBody 50 $ vec2 0 1000 |
88 | 88 | ||
89 | 89 | ||
90 | debug :: IO () | 90 | debug :: IO () |
91 | debug = evalStateT debug' b0 | 91 | debug = evalStateT debug' b0 |
92 | 92 | ||
93 | 93 | ||
94 | 94 | ||
95 | debug' :: StateT RigidBody IO () | 95 | debug' :: StateT RigidBody IO () |
96 | debug' = do | 96 | debug' = do |
97 | lift . putStrLn $ "Initial body:" | 97 | lift . putStrLn $ "Initial body:" |
98 | lift . putStrLn . show' $ b0 | 98 | lift . putStrLn . show' $ b0 |
99 | lift . putStrLn $ "Falling..." | 99 | lift . putStrLn $ "Falling..." |
100 | step $ update [gravity*50] 1 | 100 | step $ update [gravity*50] 1 |
101 | step $ update [gravity*50] 1 | 101 | step $ update [gravity*50] 1 |
102 | step $ update [gravity*50] 1 | 102 | step $ update [gravity*50] 1 |
103 | lift . putStrLn $ "Jumping" | 103 | lift . putStrLn $ "Jumping" |
104 | step $ update [gravity*50, vec2 0 9000] 1 | 104 | step $ update [gravity*50, vec2 0 9000] 1 |
105 | lift . putStrLn $ "Falling..." | 105 | lift . putStrLn $ "Falling..." |
106 | step $ update [gravity*50] 1 | 106 | step $ update [gravity*50] 1 |
107 | step $ update [gravity*50] 1 | 107 | step $ update [gravity*50] 1 |
108 | step $ update [gravity*50] 1 | 108 | step $ update [gravity*50] 1 |
109 | 109 | ||
110 | 110 | ||
111 | step :: (RigidBody -> RigidBody) -> StateT RigidBody IO () | 111 | step :: (RigidBody -> RigidBody) -> StateT RigidBody IO () |
112 | step update = do | 112 | step update = do |
113 | modify update | 113 | modify update |
114 | body <- get | 114 | body <- get |
115 | lift . putStrLn . show' $ body | 115 | lift . putStrLn . show' $ body |
116 | 116 | ||
117 | 117 | ||
118 | show' body = | 118 | show' body = |
119 | "mass " ++ (show $ mass body) ++ | 119 | "mass " ++ (show $ mass body) ++ |
120 | ", position " ++ (showVec $ position body) ++ | 120 | ", position " ++ (showVec $ position body) ++ |
121 | ", velocity " ++ (showVec $ velocity body) ++ | 121 | ", velocity " ++ (showVec $ velocity body) ++ |
122 | ", acceleration " ++ (showVec $ acceleration body) | 122 | ", acceleration " ++ (showVec $ acceleration body) |
123 | 123 | ||
124 | 124 | ||
125 | showVec v = (show $ x v) ++ ", " ++ (show $ y v)-} | 125 | showVec v = (show $ x v) ++ ", " ++ (show $ y v)-} |
diff --git a/Spear/Math/Physics/Types.hs b/Spear/Math/Physics/Types.hs index 73cd90e..59e6c74 100644 --- a/Spear/Math/Physics/Types.hs +++ b/Spear/Math/Physics/Types.hs | |||
@@ -1,11 +1,11 @@ | |||
1 | module Spear.Math.Physics.Types | 1 | module Spear.Math.Physics.Types |
2 | where | 2 | where |
3 | 3 | ||
4 | import Spear.Math.Vector | 4 | import Spear.Math.Vector |
5 | 5 | ||
6 | type Dt = Float | 6 | type Dt = Float |
7 | type Force = Vector2 | 7 | type Force = Vector2 |
8 | type Mass = Float | 8 | type Mass = Float |
9 | type Position = Vector2 | 9 | type Position = Vector2 |
10 | type Velocity = Vector2 | 10 | type Velocity = Vector2 |
11 | type Acceleration = Vector2 | 11 | type Acceleration = Vector2 |
diff --git a/Spear/Math/Plane.hs b/Spear/Math/Plane.hs index 08e4570..ee788b5 100644 --- a/Spear/Math/Plane.hs +++ b/Spear/Math/Plane.hs | |||
@@ -1,39 +1,39 @@ | |||
1 | module Spear.Math.Plane | 1 | module Spear.Math.Plane |
2 | ( | 2 | ( |
3 | Plane | 3 | Plane |
4 | , plane | 4 | , plane |
5 | , classify | 5 | , classify |
6 | ) | 6 | ) |
7 | where | 7 | where |
8 | 8 | ||
9 | import Spear.Math.Vector | 9 | import Spear.Math.Vector |
10 | 10 | ||
11 | data PointPlanePos = Front | Back | Contained deriving (Eq, Show) | 11 | data PointPlanePos = Front | Back | Contained deriving (Eq, Show) |
12 | 12 | ||
13 | data Plane = Plane | 13 | data Plane = Plane |
14 | { n :: {-# UNPACK #-} !Vector3, | 14 | { n :: {-# UNPACK #-} !Vector3, |
15 | d :: {-# UNPACK #-} !Float | 15 | d :: {-# UNPACK #-} !Float |
16 | } | 16 | } |
17 | deriving(Eq, Show) | 17 | deriving(Eq, Show) |
18 | 18 | ||
19 | -- | Construct a plane from a normal vector and a distance from the origin. | 19 | -- | Construct a plane from a normal vector and a distance from the origin. |
20 | plane :: Vector3 -> Float -> Plane | 20 | plane :: Vector3 -> Float -> Plane |
21 | plane n d = Plane (normalise n) d | 21 | plane n d = Plane (normalise n) d |
22 | 22 | ||
23 | -- | Construct a plane from three points. | 23 | -- | Construct a plane from three points. |
24 | -- | 24 | -- |
25 | -- Points must be given in counter-clockwise order. | 25 | -- Points must be given in counter-clockwise order. |
26 | fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane | 26 | fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane |
27 | fromPoints p0 p1 p2 = Plane n d | 27 | fromPoints p0 p1 p2 = Plane n d |
28 | where n = normalise $ v1 `cross` v2 | 28 | where n = normalise $ v1 `cross` v2 |
29 | v1 = p2 - p1 | 29 | v1 = p2 - p1 |
30 | v2 = p0 - p1 | 30 | v2 = p0 - p1 |
31 | d = p0 `dot` n | 31 | d = p0 `dot` n |
32 | 32 | ||
33 | -- | Classify the given point's relative position with respect to the plane. | 33 | -- | Classify the given point's relative position with respect to the plane. |
34 | classify :: Plane -> Vector3 -> PointPlanePos | 34 | classify :: Plane -> Vector3 -> PointPlanePos |
35 | classify (Plane n d) pt = | 35 | classify (Plane n d) pt = |
36 | case (n `dot` pt - d) `compare` 0 of | 36 | case (n `dot` pt - d) `compare` 0 of |
37 | GT -> Front | 37 | GT -> Front |
38 | LT -> Back | 38 | LT -> Back |
39 | EQ -> Contained | 39 | EQ -> Contained |
diff --git a/Spear/Math/Quaternion.hs b/Spear/Math/Quaternion.hs index cfc6cd2..78aca9c 100644 --- a/Spear/Math/Quaternion.hs +++ b/Spear/Math/Quaternion.hs | |||
@@ -1,108 +1,108 @@ | |||
1 | module Spear.Math.Quaternion | 1 | module Spear.Math.Quaternion |
2 | ( | 2 | ( |
3 | Quaternion | 3 | Quaternion |
4 | -- * Construction | 4 | -- * Construction |
5 | , quat | 5 | , quat |
6 | , qvec4 | 6 | , qvec4 |
7 | , qvec3 | 7 | , qvec3 |
8 | , qAxisAngle | 8 | , qAxisAngle |
9 | -- * Operations | 9 | -- * Operations |
10 | , qmul | 10 | , qmul |
11 | , qconj | 11 | , qconj |
12 | , qinv | 12 | , qinv |
13 | , qnormalise | 13 | , qnormalise |
14 | , qnorm | 14 | , qnorm |
15 | , qrot | 15 | , qrot |
16 | ) | 16 | ) |
17 | where | 17 | where |
18 | 18 | ||
19 | 19 | ||
20 | import Spear.Math.Vector | 20 | import Spear.Math.Vector |
21 | 21 | ||
22 | 22 | ||
23 | newtype Quaternion = Quaternion { getVec :: Vector4 } | 23 | newtype Quaternion = Quaternion { getVec :: Vector4 } |
24 | 24 | ||
25 | 25 | ||
26 | -- | Build a 'Quaternion'. | 26 | -- | Build a 'Quaternion'. |
27 | quat :: Float -- x | 27 | quat :: Float -- x |
28 | -> Float -- y | 28 | -> Float -- y |
29 | -> Float -- z | 29 | -> Float -- z |
30 | -> Float -- w | 30 | -> Float -- w |
31 | -> Quaternion | 31 | -> Quaternion |
32 | quat x y z w = Quaternion $ vec4 x y z w | 32 | quat x y z w = Quaternion $ vec4 x y z w |
33 | 33 | ||
34 | 34 | ||
35 | -- | Build a 'Quaternion' from the given 'Vector4'. | 35 | -- | Build a 'Quaternion' from the given 'Vector4'. |
36 | qvec4 :: Vector4 -> Quaternion | 36 | qvec4 :: Vector4 -> Quaternion |
37 | qvec4 = Quaternion | 37 | qvec4 = Quaternion |
38 | 38 | ||
39 | 39 | ||
40 | -- | Build a 'Quaternion' from the given 'Vector3' and w. | 40 | -- | Build a 'Quaternion' from the given 'Vector3' and w. |
41 | qvec3 :: Vector3 -> Float -> Quaternion | 41 | qvec3 :: Vector3 -> Float -> Quaternion |
42 | qvec3 v w = Quaternion $ vec4 (x v) (y v) (z v) w | 42 | qvec3 v w = Quaternion $ vec4 (x v) (y v) (z v) w |
43 | 43 | ||
44 | 44 | ||
45 | -- | Build a 'Quaternion' representing the given rotation. | 45 | -- | Build a 'Quaternion' representing the given rotation. |
46 | qAxisAngle :: Vector3 -> Float -> Quaternion | 46 | qAxisAngle :: Vector3 -> Float -> Quaternion |
47 | qAxisAngle axis angle = | 47 | qAxisAngle axis angle = |
48 | let s' = norm axis | 48 | let s' = norm axis |
49 | s = if s' == 0 then 1 else s' | 49 | s = if s' == 0 then 1 else s' |
50 | a = angle * toRAD * 0.5 | 50 | a = angle * toRAD * 0.5 |
51 | sa = sin a | 51 | sa = sin a |
52 | qw = cos a | 52 | qw = cos a |
53 | qx = x axis * sa * s | 53 | qx = x axis * sa * s |
54 | qy = y axis * sa * s | 54 | qy = y axis * sa * s |
55 | qz = z axis * sa * s | 55 | qz = z axis * sa * s |
56 | in | 56 | in |
57 | Quaternion $ vec4 qx qy qz qw | 57 | Quaternion $ vec4 qx qy qz qw |
58 | 58 | ||
59 | 59 | ||
60 | -- | Compute the product of the given two quaternions. | 60 | -- | Compute the product of the given two quaternions. |
61 | qmul :: Quaternion -> Quaternion -> Quaternion | 61 | qmul :: Quaternion -> Quaternion -> Quaternion |
62 | qmul (Quaternion q1) (Quaternion q2) = | 62 | qmul (Quaternion q1) (Quaternion q2) = |
63 | let x1 = x q1 | 63 | let x1 = x q1 |
64 | y1 = y q1 | 64 | y1 = y q1 |
65 | z1 = z q1 | 65 | z1 = z q1 |
66 | w1 = w q1 | 66 | w1 = w q1 |
67 | x2 = x q2 | 67 | x2 = x q2 |
68 | y2 = y q2 | 68 | y2 = y q2 |
69 | z2 = y q2 | 69 | z2 = y q2 |
70 | w2 = w q2 | 70 | w2 = w q2 |
71 | w' = w1*w2 - x1*x2 - y1*y2 - z1*z2 | 71 | w' = w1*w2 - x1*x2 - y1*y2 - z1*z2 |
72 | x' = w1*x2 + x1*w2 + y1*z2 - z1*y2 | 72 | x' = w1*x2 + x1*w2 + y1*z2 - z1*y2 |
73 | y' = w1*y2 - x1*z2 + y1*w2 + z1*x2 | 73 | y' = w1*y2 - x1*z2 + y1*w2 + z1*x2 |
74 | z' = w1*z2 + x1*y2 - y1*x2 + z1*w2 | 74 | z' = w1*z2 + x1*y2 - y1*x2 + z1*w2 |
75 | in | 75 | in |
76 | Quaternion $ vec4 x' y' z' w' | 76 | Quaternion $ vec4 x' y' z' w' |
77 | 77 | ||
78 | 78 | ||
79 | -- | Compute the conjugate of the given 'Quaternion'. | 79 | -- | Compute the conjugate of the given 'Quaternion'. |
80 | qconj :: Quaternion -> Quaternion | 80 | qconj :: Quaternion -> Quaternion |
81 | qconj (Quaternion q) = Quaternion $ vec4 (-x q) (-y q) (-z q) (w q) | 81 | qconj (Quaternion q) = Quaternion $ vec4 (-x q) (-y q) (-z q) (w q) |
82 | 82 | ||
83 | 83 | ||
84 | -- | Invert the given 'Quaternion'. | 84 | -- | Invert the given 'Quaternion'. |
85 | qinv :: Quaternion -> Quaternion | 85 | qinv :: Quaternion -> Quaternion |
86 | qinv (Quaternion q) = | 86 | qinv (Quaternion q) = |
87 | let m = normSq q | 87 | let m = normSq q |
88 | in Quaternion $ vec4 (-x q / m) (-y q / m) (-z q / m) (w q / m) | 88 | in Quaternion $ vec4 (-x q / m) (-y q / m) (-z q / m) (w q / m) |
89 | 89 | ||
90 | 90 | ||
91 | -- | Normalise the given 'Quaternion'. | 91 | -- | Normalise the given 'Quaternion'. |
92 | qnormalise :: Quaternion -> Quaternion | 92 | qnormalise :: Quaternion -> Quaternion |
93 | qnormalise = Quaternion . normalise . getVec | 93 | qnormalise = Quaternion . normalise . getVec |
94 | 94 | ||
95 | 95 | ||
96 | -- | Compute the norm of the given 'Quaternion'. | 96 | -- | Compute the norm of the given 'Quaternion'. |
97 | qnorm :: Quaternion -> Float | 97 | qnorm :: Quaternion -> Float |
98 | qnorm = norm . getVec | 98 | qnorm = norm . getVec |
99 | 99 | ||
100 | 100 | ||
101 | -- | Rotate the given 'Vector3'. | 101 | -- | Rotate the given 'Vector3'. |
102 | qrot :: Quaternion -> Vector3 -> Vector3 | 102 | qrot :: Quaternion -> Vector3 -> Vector3 |
103 | qrot q v = toVec3 $ q `qmul` qvec3 v 0 `qmul` qconj q | 103 | qrot q v = toVec3 $ q `qmul` qvec3 v 0 `qmul` qconj q |
104 | where toVec3 (Quaternion q) = vec3 (x q) (y q) (z q) | 104 | where toVec3 (Quaternion q) = vec3 (x q) (y q) (z q) |
105 | 105 | ||
106 | 106 | ||
107 | toRAD = pi / 180 | 107 | toRAD = pi / 180 |
108 | 108 | ||
diff --git a/Spear/Math/Ray.hs b/Spear/Math/Ray.hs index b0359a1..009455d 100644 --- a/Spear/Math/Ray.hs +++ b/Spear/Math/Ray.hs | |||
@@ -1,31 +1,31 @@ | |||
1 | module Spear.Math.Ray | 1 | module Spear.Math.Ray |
2 | ( | 2 | ( |
3 | Ray(..) | 3 | Ray(..) |
4 | , raylr | 4 | , raylr |
5 | , rayfb | 5 | , rayfb |
6 | ) | 6 | ) |
7 | where | 7 | where |
8 | 8 | ||
9 | 9 | ||
10 | import Spear.Math.Utils | 10 | import Spear.Math.Utils |
11 | import Spear.Math.Vector | 11 | import Spear.Math.Vector |
12 | 12 | ||
13 | 13 | ||
14 | data Ray = Ray | 14 | data Ray = Ray |
15 | { origin :: {-# UNPACK #-} !Vector2 | 15 | { origin :: {-# UNPACK #-} !Vector2 |
16 | , dir :: {-# UNPACK #-} !Vector2 | 16 | , dir :: {-# UNPACK #-} !Vector2 |
17 | } | 17 | } |
18 | 18 | ||
19 | 19 | ||
20 | -- | Classify the given point's position with respect to the given ray. Left/Right test. | 20 | -- | Classify the given point's position with respect to the given ray. Left/Right test. |
21 | raylr :: Ray -> Vector2 -> Side | 21 | raylr :: Ray -> Vector2 -> Side |
22 | raylr (Ray o d) p | 22 | raylr (Ray o d) p |
23 | | orientation2d o (o+d) p < 0 = R | 23 | | orientation2d o (o+d) p < 0 = R |
24 | | otherwise = L | 24 | | otherwise = L |
25 | 25 | ||
26 | 26 | ||
27 | -- | Classify the given point's position with respect to the given ray. Front/Back test. | 27 | -- | Classify the given point's position with respect to the given ray. Front/Back test. |
28 | rayfb :: Ray -> Vector2 -> Face | 28 | rayfb :: Ray -> Vector2 -> Face |
29 | rayfb (Ray o d) p | 29 | rayfb (Ray o d) p |
30 | | orientation2d o (perp d) p > 0 = F | 30 | | orientation2d o (perp d) p > 0 = F |
31 | | otherwise = B | 31 | | otherwise = B |
diff --git a/Spear/Math/Segment.hs b/Spear/Math/Segment.hs index c632838..82fd7e0 100644 --- a/Spear/Math/Segment.hs +++ b/Spear/Math/Segment.hs | |||
@@ -1,21 +1,21 @@ | |||
1 | module Spear.Math.Segment | 1 | module Spear.Math.Segment |
2 | ( | 2 | ( |
3 | Segment(..) | 3 | Segment(..) |
4 | , seglr | 4 | , seglr |
5 | ) | 5 | ) |
6 | where | 6 | where |
7 | 7 | ||
8 | 8 | ||
9 | import Spear.Math.Utils | 9 | import Spear.Math.Utils |
10 | import Spear.Math.Vector | 10 | import Spear.Math.Vector |
11 | 11 | ||
12 | 12 | ||
13 | -- | A line segment in 2D space. | 13 | -- | A line segment in 2D space. |
14 | data Segment = Segment {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 | 14 | data Segment = Segment {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 |
15 | 15 | ||
16 | 16 | ||
17 | -- | Classify the given point's position with respect to the given segment. | 17 | -- | Classify the given point's position with respect to the given segment. |
18 | seglr :: Segment -> Vector2 -> Side | 18 | seglr :: Segment -> Vector2 -> Side |
19 | seglr (Segment p0 p1) p | 19 | seglr (Segment p0 p1) p |
20 | | orientation2d p0 p1 p < 0 = R | 20 | | orientation2d p0 p1 p < 0 = R |
21 | | otherwise = L | 21 | | otherwise = L |
diff --git a/Spear/Math/Spatial2.hs b/Spear/Math/Spatial2.hs index 341282b..b9dde44 100644 --- a/Spear/Math/Spatial2.hs +++ b/Spear/Math/Spatial2.hs | |||
@@ -1,75 +1,75 @@ | |||
1 | module Spear.Math.Spatial2 | 1 | module Spear.Math.Spatial2 |
2 | where | 2 | where |
3 | 3 | ||
4 | 4 | ||
5 | import Spear.Math.Vector | 5 | import Spear.Math.Vector |
6 | import Spear.Math.Matrix3 as M | 6 | import Spear.Math.Matrix3 as M |
7 | 7 | ||
8 | 8 | ||
9 | -- | An entity that can be moved around in 2D space. | 9 | -- | An entity that can be moved around in 2D space. |
10 | class Spatial2 s where | 10 | class Spatial2 s where |
11 | 11 | ||
12 | -- | Move the spatial. | 12 | -- | Move the spatial. |
13 | move :: Vector2 -> s -> s | 13 | move :: Vector2 -> s -> s |
14 | 14 | ||
15 | -- | Move the spatial forwards. | 15 | -- | Move the spatial forwards. |
16 | moveFwd :: Float -> s -> s | 16 | moveFwd :: Float -> s -> s |
17 | 17 | ||
18 | -- | Move the spatial backwards. | 18 | -- | Move the spatial backwards. |
19 | moveBack :: Float -> s -> s | 19 | moveBack :: Float -> s -> s |
20 | 20 | ||
21 | -- | Make the spatial strafe left. | 21 | -- | Make the spatial strafe left. |
22 | strafeLeft :: Float -> s -> s | 22 | strafeLeft :: Float -> s -> s |
23 | 23 | ||
24 | -- | Make the spatial Strafe right. | 24 | -- | Make the spatial Strafe right. |
25 | strafeRight :: Float -> s -> s | 25 | strafeRight :: Float -> s -> s |
26 | 26 | ||
27 | -- | Rotate the spatial. | 27 | -- | Rotate the spatial. |
28 | rotate :: Float -> s -> s | 28 | rotate :: Float -> s -> s |
29 | 29 | ||
30 | -- | Set the spatial's rotation. | 30 | -- | Set the spatial's rotation. |
31 | setRotation :: Float -> s -> s | 31 | setRotation :: Float -> s -> s |
32 | 32 | ||
33 | -- | Get the spatial position. | 33 | -- | Get the spatial position. |
34 | pos :: s -> Vector2 | 34 | pos :: s -> Vector2 |
35 | 35 | ||
36 | -- | Get the spatial's forward vector. | 36 | -- | Get the spatial's forward vector. |
37 | fwd :: s -> Vector2 | 37 | fwd :: s -> Vector2 |
38 | 38 | ||
39 | -- | Get the spatial's up vector. | 39 | -- | Get the spatial's up vector. |
40 | up :: s -> Vector2 | 40 | up :: s -> Vector2 |
41 | 41 | ||
42 | -- | Get the spatial's right vector. | 42 | -- | Get the spatial's right vector. |
43 | right :: s -> Vector2 | 43 | right :: s -> Vector2 |
44 | 44 | ||
45 | -- | Get the spatial's transform. | 45 | -- | Get the spatial's transform. |
46 | transform :: s -> Matrix3 | 46 | transform :: s -> Matrix3 |
47 | 47 | ||
48 | -- | Set the spatial's transform. | 48 | -- | Set the spatial's transform. |
49 | setTransform :: Matrix3 -> s -> s | 49 | setTransform :: Matrix3 -> s -> s |
50 | 50 | ||
51 | -- | Set the spatial's position. | 51 | -- | Set the spatial's position. |
52 | setPos :: Vector2 -> s -> s | 52 | setPos :: Vector2 -> s -> s |
53 | 53 | ||
54 | -- | Make the spatial look at the given point. | 54 | -- | Make the spatial look at the given point. |
55 | lookAt :: Vector2 -> s -> s | 55 | lookAt :: Vector2 -> s -> s |
56 | lookAt pt s = | 56 | lookAt pt s = |
57 | let position = pos s | 57 | let position = pos s |
58 | fwd = normalise $ pt - position | 58 | fwd = normalise $ pt - position |
59 | r = perp fwd | 59 | r = perp fwd |
60 | in | 60 | in |
61 | setTransform (M.transform r fwd position) s | 61 | setTransform (M.transform r fwd position) s |
62 | 62 | ||
63 | -- | Make the 'Spatial' orbit around the given point | 63 | -- | Make the 'Spatial' orbit around the given point |
64 | orbit :: Vector2 -- ^ Target point | 64 | orbit :: Vector2 -- ^ Target point |
65 | -> Float -- ^ Angle | 65 | -> Float -- ^ Angle |
66 | -> Float -- ^ Orbit radius | 66 | -> Float -- ^ Orbit radius |
67 | -> s | 67 | -> s |
68 | -> s | 68 | -> s |
69 | 69 | ||
70 | orbit pt angle radius s = | 70 | orbit pt angle radius s = |
71 | let a = angle * pi / 180 | 71 | let a = angle * pi / 180 |
72 | px = (x pt) + radius * sin a | 72 | px = (x pt) + radius * sin a |
73 | py = (y pt) + radius * cos a | 73 | py = (y pt) + radius * cos a |
74 | in | 74 | in |
75 | setPos (vec2 px py) s | 75 | setPos (vec2 px py) s |
diff --git a/Spear/Math/Spatial3.hs b/Spear/Math/Spatial3.hs index 2027514..c9495eb 100644 --- a/Spear/Math/Spatial3.hs +++ b/Spear/Math/Spatial3.hs | |||
@@ -1,161 +1,161 @@ | |||
1 | module Spear.Math.Spatial3 | 1 | module Spear.Math.Spatial3 |
2 | ( | 2 | ( |
3 | Spatial3(..) | 3 | Spatial3(..) |
4 | , Obj3 | 4 | , Obj3 |
5 | , fromVectors | 5 | , fromVectors |
6 | , fromTransform | 6 | , fromTransform |
7 | ) | 7 | ) |
8 | where | 8 | where |
9 | 9 | ||
10 | import Spear.Math.Vector | 10 | import Spear.Math.Vector |
11 | import qualified Spear.Math.Matrix4 as M | 11 | import qualified Spear.Math.Matrix4 as M |
12 | 12 | ||
13 | type Matrix4 = M.Matrix4 | 13 | type Matrix4 = M.Matrix4 |
14 | 14 | ||
15 | class Spatial3 s where | 15 | class Spatial3 s where |
16 | -- | Gets the spatial's internal Obj3. | 16 | -- | Gets the spatial's internal Obj3. |
17 | getObj3 :: s -> Obj3 | 17 | getObj3 :: s -> Obj3 |
18 | 18 | ||
19 | -- | Set the spatial's internal Obj3. | 19 | -- | Set the spatial's internal Obj3. |
20 | setObj3 :: s -> Obj3 -> s | 20 | setObj3 :: s -> Obj3 -> s |
21 | 21 | ||
22 | -- | Move the spatial. | 22 | -- | Move the spatial. |
23 | move :: Vector3 -> s -> s | 23 | move :: Vector3 -> s -> s |
24 | move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } | 24 | move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } |
25 | 25 | ||
26 | -- | Move the spatial forwards. | 26 | -- | Move the spatial forwards. |
27 | moveFwd :: Float -> s -> s | 27 | moveFwd :: Float -> s -> s |
28 | moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } | 28 | moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } |
29 | 29 | ||
30 | -- | Move the spatial backwards. | 30 | -- | Move the spatial backwards. |
31 | moveBack :: Float -> s -> s | 31 | moveBack :: Float -> s -> s |
32 | moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } | 32 | moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } |
33 | 33 | ||
34 | -- | Make the spatial strafe left. | 34 | -- | Make the spatial strafe left. |
35 | strafeLeft :: Float -> s -> s | 35 | strafeLeft :: Float -> s -> s |
36 | strafeLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } | 36 | strafeLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } |
37 | 37 | ||
38 | -- | Make the spatial Strafe right. | 38 | -- | Make the spatial Strafe right. |
39 | strafeRight :: Float -> s -> s | 39 | strafeRight :: Float -> s -> s |
40 | strafeRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } | 40 | strafeRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } |
41 | 41 | ||
42 | -- | Rotate the spatial about the given axis. | 42 | -- | Rotate the spatial about the given axis. |
43 | rotate :: Vector3 -> Float -> s -> s | 43 | rotate :: Vector3 -> Float -> s -> s |
44 | rotate axis a s = | 44 | rotate axis a s = |
45 | let t = transform s | 45 | let t = transform s |
46 | axis' = M.inverseTransform t `M.muld` axis | 46 | axis' = M.inverseTransform t `M.muld` axis |
47 | in setTransform (t * M.axisAngle axis' a) s | 47 | in setTransform (t * M.axisAngle axis' a) s |
48 | 48 | ||
49 | -- | Rotate the spatial about its local X axis. | 49 | -- | Rotate the spatial about its local X axis. |
50 | pitch :: Float -> s -> s | 50 | pitch :: Float -> s -> s |
51 | pitch a s = | 51 | pitch a s = |
52 | let o = getObj3 s | 52 | let o = getObj3 s |
53 | a' = toRAD a | 53 | a' = toRAD a |
54 | sa = sin a' | 54 | sa = sin a' |
55 | ca = cos a' | 55 | ca = cos a' |
56 | f' = normalise $ scale ca (f o) + scale sa (u o) | 56 | f' = normalise $ scale ca (f o) + scale sa (u o) |
57 | u' = normalise $ r o `cross` f' | 57 | u' = normalise $ r o `cross` f' |
58 | in setObj3 s $ o { u = u', f = f' } | 58 | in setObj3 s $ o { u = u', f = f' } |
59 | 59 | ||
60 | -- | Rotate the spatial about its local Y axis. | 60 | -- | Rotate the spatial about its local Y axis. |
61 | yaw :: Float -> s -> s | 61 | yaw :: Float -> s -> s |
62 | yaw a s = | 62 | yaw a s = |
63 | let o = getObj3 s | 63 | let o = getObj3 s |
64 | a' = toRAD a | 64 | a' = toRAD a |
65 | sa = sin a' | 65 | sa = sin a' |
66 | ca = cos a' | 66 | ca = cos a' |
67 | r' = normalise $ scale ca (r o) + scale sa (f o) | 67 | r' = normalise $ scale ca (r o) + scale sa (f o) |
68 | f' = normalise $ u o `cross` r' | 68 | f' = normalise $ u o `cross` r' |
69 | in setObj3 s $ o { r = r', f = f' } | 69 | in setObj3 s $ o { r = r', f = f' } |
70 | 70 | ||
71 | -- | Rotate the spatial about its local Z axis. | 71 | -- | Rotate the spatial about its local Z axis. |
72 | roll :: Float -> s -> s | 72 | roll :: Float -> s -> s |
73 | roll a s = | 73 | roll a s = |
74 | let o = getObj3 s | 74 | let o = getObj3 s |
75 | a' = toRAD a | 75 | a' = toRAD a |
76 | sa = sin a' | 76 | sa = sin a' |
77 | ca = cos a' | 77 | ca = cos a' |
78 | u' = normalise $ scale ca (u o) - scale sa (r o) | 78 | u' = normalise $ scale ca (u o) - scale sa (r o) |
79 | r' = normalise $ f o `cross` u' | 79 | r' = normalise $ f o `cross` u' |
80 | in setObj3 s $ o { r = r', u = u' } | 80 | in setObj3 s $ o { r = r', u = u' } |
81 | 81 | ||
82 | -- | Get the spatial's position. | 82 | -- | Get the spatial's position. |
83 | pos :: s -> Vector3 | 83 | pos :: s -> Vector3 |
84 | pos = p . getObj3 | 84 | pos = p . getObj3 |
85 | 85 | ||
86 | -- | Get the spatial's forward vector. | 86 | -- | Get the spatial's forward vector. |
87 | fwd :: s -> Vector3 | 87 | fwd :: s -> Vector3 |
88 | fwd = f . getObj3 | 88 | fwd = f . getObj3 |
89 | 89 | ||
90 | -- | Get the spatial's up vector. | 90 | -- | Get the spatial's up vector. |
91 | up :: s -> Vector3 | 91 | up :: s -> Vector3 |
92 | up = u . getObj3 | 92 | up = u . getObj3 |
93 | 93 | ||
94 | -- | Get the spatial's right vector. | 94 | -- | Get the spatial's right vector. |
95 | right :: s -> Vector3 | 95 | right :: s -> Vector3 |
96 | right = r . getObj3 | 96 | right = r . getObj3 |
97 | 97 | ||
98 | -- | Get the spatial's transform. | 98 | -- | Get the spatial's transform. |
99 | transform :: s -> Matrix4 | 99 | transform :: s -> Matrix4 |
100 | transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) | 100 | transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) |
101 | 101 | ||
102 | -- | Set the spatial's transform. | 102 | -- | Set the spatial's transform. |
103 | setTransform :: Matrix4 -> s -> s | 103 | setTransform :: Matrix4 -> s -> s |
104 | setTransform t s = | 104 | setTransform t s = |
105 | let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) | 105 | let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) |
106 | in setObj3 s o | 106 | in setObj3 s o |
107 | 107 | ||
108 | -- | Set the spatial's position. | 108 | -- | Set the spatial's position. |
109 | setPos :: Vector3 -> s -> s | 109 | setPos :: Vector3 -> s -> s |
110 | setPos pos s = setObj3 s $ (getObj3 s) { p = pos } | 110 | setPos pos s = setObj3 s $ (getObj3 s) { p = pos } |
111 | 111 | ||
112 | -- | Make the spatial look at the given point. | 112 | -- | Make the spatial look at the given point. |
113 | lookAt :: Vector3 -> s -> s | 113 | lookAt :: Vector3 -> s -> s |
114 | lookAt pt s = | 114 | lookAt pt s = |
115 | let position = pos s | 115 | let position = pos s |
116 | fwd = normalise $ pt - position | 116 | fwd = normalise $ pt - position |
117 | r = fwd `cross` unity3 | 117 | r = fwd `cross` unity3 |
118 | u = r `cross` fwd | 118 | u = r `cross` fwd |
119 | in | 119 | in |
120 | setTransform (M.transform r u (-fwd) position) s | 120 | setTransform (M.transform r u (-fwd) position) s |
121 | 121 | ||
122 | -- | Make the spatial orbit around the given point | 122 | -- | Make the spatial orbit around the given point |
123 | orbit :: Vector3 -- ^ Target point | 123 | orbit :: Vector3 -- ^ Target point |
124 | -> Float -- ^ Horizontal angle | 124 | -> Float -- ^ Horizontal angle |
125 | -> Float -- ^ Vertical angle | 125 | -> Float -- ^ Vertical angle |
126 | -> Float -- ^ Orbit radius. | 126 | -> Float -- ^ Orbit radius. |
127 | -> s | 127 | -> s |
128 | -> s | 128 | -> s |
129 | 129 | ||
130 | orbit pt anglex angley radius s = | 130 | orbit pt anglex angley radius s = |
131 | let ax = anglex * pi / 180 | 131 | let ax = anglex * pi / 180 |
132 | ay = angley * pi / 180 | 132 | ay = angley * pi / 180 |
133 | sx = sin ax | 133 | sx = sin ax |
134 | sy = sin ay | 134 | sy = sin ay |
135 | cx = cos ax | 135 | cx = cos ax |
136 | cy = cos ay | 136 | cy = cos ay |
137 | px = (x pt) + radius*cy*sx | 137 | px = (x pt) + radius*cy*sx |
138 | py = (y pt) + radius*sy | 138 | py = (y pt) + radius*sy |
139 | pz = (z pt) + radius*cx*cy | 139 | pz = (z pt) + radius*cx*cy |
140 | in | 140 | in |
141 | setPos (vec3 px py pz) s | 141 | setPos (vec3 px py pz) s |
142 | 142 | ||
143 | -- | An object in 3D space. | 143 | -- | An object in 3D space. |
144 | data Obj3 = Obj3 | 144 | data Obj3 = Obj3 |
145 | { r :: Vector3 | 145 | { r :: Vector3 |
146 | , u :: Vector3 | 146 | , u :: Vector3 |
147 | , f :: Vector3 | 147 | , f :: Vector3 |
148 | , p :: Vector3 | 148 | , p :: Vector3 |
149 | } deriving Show | 149 | } deriving Show |
150 | 150 | ||
151 | instance Spatial3 Obj3 where | 151 | instance Spatial3 Obj3 where |
152 | getObj3 = id | 152 | getObj3 = id |
153 | setObj3 _ o' = o' | 153 | setObj3 _ o' = o' |
154 | 154 | ||
155 | fromVectors :: Right3 -> Up3 -> Forward3 -> Position3 -> Obj3 | 155 | fromVectors :: Right3 -> Up3 -> Forward3 -> Position3 -> Obj3 |
156 | fromVectors = Obj3 | 156 | fromVectors = Obj3 |
157 | 157 | ||
158 | fromTransform :: Matrix4 -> Obj3 | 158 | fromTransform :: Matrix4 -> Obj3 |
159 | fromTransform m = Obj3 (M.right m) (M.up m) (M.forward m) (M.position m) | 159 | fromTransform m = Obj3 (M.right m) (M.up m) (M.forward m) (M.position m) |
160 | 160 | ||
161 | toRAD = (*pi) . (/180) | 161 | toRAD = (*pi) . (/180) |
diff --git a/Spear/Math/Sphere.hs b/Spear/Math/Sphere.hs index 9c80811..197a9b2 100644 --- a/Spear/Math/Sphere.hs +++ b/Spear/Math/Sphere.hs | |||
@@ -1,26 +1,26 @@ | |||
1 | module Spear.Math.Sphere | 1 | module Spear.Math.Sphere |
2 | where | 2 | where |
3 | 3 | ||
4 | import Spear.Math.Vector | 4 | import Spear.Math.Vector |
5 | 5 | ||
6 | import Data.List (foldl') | 6 | import Data.List (foldl') |
7 | 7 | ||
8 | -- | A sphere in 3D space. | 8 | -- | A sphere in 3D space. |
9 | data Sphere = Sphere | 9 | data Sphere = Sphere |
10 | { center :: {-# UNPACK #-} !Vector3 | 10 | { center :: {-# UNPACK #-} !Vector3 |
11 | , radius :: {-# UNPACK #-} !Float | 11 | , radius :: {-# UNPACK #-} !Float |
12 | } | 12 | } |
13 | 13 | ||
14 | -- | Create a sphere from the given points. | 14 | -- | Create a sphere from the given points. |
15 | sphere :: [Vector3] -> Sphere | 15 | sphere :: [Vector3] -> Sphere |
16 | sphere [] = Sphere zero3 0 | 16 | sphere [] = Sphere zero3 0 |
17 | sphere (x:xs) = Sphere c r | 17 | sphere (x:xs) = Sphere c r |
18 | where | 18 | where |
19 | c = pmin + (pmax-pmin)/2 | 19 | c = pmin + (pmax-pmin)/2 |
20 | r = norm $ pmax - c | 20 | r = norm $ pmax - c |
21 | (pmin,pmax) = foldl' update (x,x) xs | 21 | (pmin,pmax) = foldl' update (x,x) xs |
22 | update (pmin,pmax) p = (min p pmin, max p pmax) | 22 | update (pmin,pmax) p = (min p pmin, max p pmax) |
23 | 23 | ||
24 | -- | Return 'True' if the given sphere contains the given point, 'False' otherwise. | 24 | -- | Return 'True' if the given sphere contains the given point, 'False' otherwise. |
25 | circlept :: Sphere -> Vector3 -> Bool | 25 | circlept :: Sphere -> Vector3 -> Bool |
26 | circlept (Sphere c r) p = r*r >= normSq (p - c) | 26 | circlept (Sphere c r) p = r*r >= normSq (p - c) |
diff --git a/Spear/Math/Triangle.hs b/Spear/Math/Triangle.hs index 96cfa1a..04c2639 100644 --- a/Spear/Math/Triangle.hs +++ b/Spear/Math/Triangle.hs | |||
@@ -1,40 +1,40 @@ | |||
1 | module Spear.Math.Triangle | 1 | module Spear.Math.Triangle |
2 | ( | 2 | ( |
3 | Triangle(..) | 3 | Triangle(..) |
4 | ) | 4 | ) |
5 | where | 5 | where |
6 | 6 | ||
7 | 7 | ||
8 | import Spear.Math.Vector | 8 | import Spear.Math.Vector |
9 | 9 | ||
10 | import Foreign.C.Types | 10 | import Foreign.C.Types |
11 | import Foreign.Storable | 11 | import Foreign.Storable |
12 | 12 | ||
13 | 13 | ||
14 | data Triangle = Triangle | 14 | data Triangle = Triangle |
15 | { p0 :: {-# UNPACK #-} !Vector3 | 15 | { p0 :: {-# UNPACK #-} !Vector3 |
16 | , p1 :: {-# UNPACK #-} !Vector3 | 16 | , p1 :: {-# UNPACK #-} !Vector3 |
17 | , p2 :: {-# UNPACK #-} !Vector3 | 17 | , p2 :: {-# UNPACK #-} !Vector3 |
18 | } | 18 | } |
19 | 19 | ||
20 | 20 | ||
21 | sizeVector3 = 3 * sizeOf (undefined :: CFloat) | 21 | sizeVector3 = 3 * sizeOf (undefined :: CFloat) |
22 | 22 | ||
23 | 23 | ||
24 | instance Storable Triangle where | 24 | instance Storable Triangle where |
25 | 25 | ||
26 | sizeOf _ = 3 * sizeVector3 | 26 | sizeOf _ = 3 * sizeVector3 |
27 | alignment _ = alignment (undefined :: CFloat) | 27 | alignment _ = alignment (undefined :: CFloat) |
28 | 28 | ||
29 | peek ptr = do | 29 | peek ptr = do |
30 | p0 <- peekByteOff ptr 0 | 30 | p0 <- peekByteOff ptr 0 |
31 | p1 <- peekByteOff ptr $ 1 * sizeVector3 | 31 | p1 <- peekByteOff ptr $ 1 * sizeVector3 |
32 | p2 <- peekByteOff ptr $ 2 * sizeVector3 | 32 | p2 <- peekByteOff ptr $ 2 * sizeVector3 |
33 | 33 | ||
34 | return $ Triangle p0 p1 p2 | 34 | return $ Triangle p0 p1 p2 |
35 | 35 | ||
36 | 36 | ||
37 | poke ptr (Triangle p0 p1 p2) = do | 37 | poke ptr (Triangle p0 p1 p2) = do |
38 | pokeByteOff ptr 0 p0 | 38 | pokeByteOff ptr 0 p0 |
39 | pokeByteOff ptr (1*sizeVector3) p1 | 39 | pokeByteOff ptr (1*sizeVector3) p1 |
40 | pokeByteOff ptr (2*sizeVector3) p2 | 40 | pokeByteOff ptr (2*sizeVector3) p2 |
diff --git a/Spear/Math/Utils.hs b/Spear/Math/Utils.hs index 90ebda9..04c97bc 100644 --- a/Spear/Math/Utils.hs +++ b/Spear/Math/Utils.hs | |||
@@ -1,38 +1,38 @@ | |||
1 | module Spear.Math.Utils | 1 | module Spear.Math.Utils |
2 | ( | 2 | ( |
3 | Side(..) | 3 | Side(..) |
4 | , Face(..) | 4 | , Face(..) |
5 | , orientation2d | 5 | , orientation2d |
6 | , viewToWorld2d | 6 | , viewToWorld2d |
7 | ) | 7 | ) |
8 | where | 8 | where |
9 | 9 | ||
10 | 10 | ||
11 | import Spear.Math.Matrix4 as M4 | 11 | import Spear.Math.Matrix4 as M4 |
12 | import Spear.Math.Vector as V | 12 | import Spear.Math.Vector as V |
13 | 13 | ||
14 | 14 | ||
15 | data Side = L | R deriving (Eq, Show) | 15 | data Side = L | R deriving (Eq, Show) |
16 | 16 | ||
17 | 17 | ||
18 | data Face = F | B deriving (Eq, Show) | 18 | data Face = F | B deriving (Eq, Show) |
19 | 19 | ||
20 | 20 | ||
21 | -- | Return the signed area of the triangle defined by the given points. | 21 | -- | Return the signed area of the triangle defined by the given points. |
22 | orientation2d :: Vector2 -> Vector2 -> Vector2 -> Float | 22 | orientation2d :: Vector2 -> Vector2 -> Vector2 -> Float |
23 | orientation2d p q r = (x q - x p) * (y r - y p) - (y q - y p) * (x r - x p) | 23 | orientation2d p q r = (x q - x p) * (y r - y p) - (y q - y p) * (x r - x p) |
24 | 24 | ||
25 | 25 | ||
26 | -- | Project the given point in view space onto the XZ plane in world space. | 26 | -- | Project the given point in view space onto the XZ plane in world space. |
27 | viewToWorld2d :: Vector2 -- ^ Point in view space | 27 | viewToWorld2d :: Vector2 -- ^ Point in view space |
28 | -> Matrix4 -- ^ Inverse view matrix | 28 | -> Matrix4 -- ^ Inverse view matrix |
29 | -> Vector2 -- ^ Projection of the given point | 29 | -> Vector2 -- ^ Projection of the given point |
30 | viewToWorld2d p viewI = | 30 | viewToWorld2d p viewI = |
31 | let | 31 | let |
32 | p1' = vec3 (x p) (y p) 0 | 32 | p1' = vec3 (x p) (y p) 0 |
33 | p1 = viewI `mulp` p1' | 33 | p1 = viewI `mulp` p1' |
34 | p2 = p1 - M4.forward viewI | 34 | p2 = p1 - M4.forward viewI |
35 | lambda = (y p1 / (y p1 - y p2)) | 35 | lambda = (y p1 / (y p1 - y p2)) |
36 | p' = p1 + V.scale lambda (p2 - p1) | 36 | p' = p1 + V.scale lambda (p2 - p1) |
37 | in | 37 | in |
38 | vec2 (x p') (-z p') | 38 | vec2 (x p') (-z p') |
diff --git a/Spear/Math/Vector.hs b/Spear/Math/Vector.hs index a1cb9e8..dd5e496 100644 --- a/Spear/Math/Vector.hs +++ b/Spear/Math/Vector.hs | |||
@@ -1,13 +1,13 @@ | |||
1 | module Spear.Math.Vector | 1 | module Spear.Math.Vector |
2 | ( | 2 | ( |
3 | module Spear.Math.Vector.Vector2 | 3 | module Spear.Math.Vector.Vector2 |
4 | , module Spear.Math.Vector.Vector3 | 4 | , module Spear.Math.Vector.Vector3 |
5 | , module Spear.Math.Vector.Vector4 | 5 | , module Spear.Math.Vector.Vector4 |
6 | , module Spear.Math.Vector.Class | 6 | , module Spear.Math.Vector.Class |
7 | ) | 7 | ) |
8 | where | 8 | where |
9 | 9 | ||
10 | import Spear.Math.Vector.Vector2 | 10 | import Spear.Math.Vector.Vector2 |
11 | import Spear.Math.Vector.Vector3 | 11 | import Spear.Math.Vector.Vector3 |
12 | import Spear.Math.Vector.Vector4 | 12 | import Spear.Math.Vector.Vector4 |
13 | import Spear.Math.Vector.Class | 13 | import Spear.Math.Vector.Class |
diff --git a/Spear/Math/Vector/Class.hs b/Spear/Math/Vector/Class.hs index 05a7206..19ddfac 100644 --- a/Spear/Math/Vector/Class.hs +++ b/Spear/Math/Vector/Class.hs | |||
@@ -1,43 +1,43 @@ | |||
1 | module Spear.Math.Vector.Class | 1 | module Spear.Math.Vector.Class |
2 | where | 2 | where |
3 | 3 | ||
4 | class (Fractional a, Ord a) => VectorClass a where | 4 | class (Fractional a, Ord a) => VectorClass a where |
5 | -- | Create a vector from the given list. | 5 | -- | Create a vector from the given list. |
6 | fromList :: [Float] -> a | 6 | fromList :: [Float] -> a |
7 | 7 | ||
8 | -- | Return the vector's x coordinate. | 8 | -- | Return the vector's x coordinate. |
9 | x :: a -> Float | 9 | x :: a -> Float |
10 | x _ = 0 | 10 | x _ = 0 |
11 | 11 | ||
12 | -- | Return the vector's y coordinate. | 12 | -- | Return the vector's y coordinate. |
13 | y :: a -> Float | 13 | y :: a -> Float |
14 | y _ = 0 | 14 | y _ = 0 |
15 | 15 | ||
16 | -- | Return the vector's z coordinate. | 16 | -- | Return the vector's z coordinate. |
17 | z :: a -> Float | 17 | z :: a -> Float |
18 | z _ = 0 | 18 | z _ = 0 |
19 | 19 | ||
20 | -- | Return the vector's w coordinate. | 20 | -- | Return the vector's w coordinate. |
21 | w :: a -> Float | 21 | w :: a -> Float |
22 | w _ = 0 | 22 | w _ = 0 |
23 | 23 | ||
24 | -- | Return the vector's ith coordinate. | 24 | -- | Return the vector's ith coordinate. |
25 | (!) :: a -> Int -> Float | 25 | (!) :: a -> Int -> Float |
26 | 26 | ||
27 | -- | Compute the given vectors' dot product. | 27 | -- | Compute the given vectors' dot product. |
28 | dot :: a -> a -> Float | 28 | dot :: a -> a -> Float |
29 | 29 | ||
30 | -- | Compute the given vector's squared norm. | 30 | -- | Compute the given vector's squared norm. |
31 | normSq :: a -> Float | 31 | normSq :: a -> Float |
32 | 32 | ||
33 | -- | Compute the given vector's norm. | 33 | -- | Compute the given vector's norm. |
34 | norm :: a -> Float | 34 | norm :: a -> Float |
35 | 35 | ||
36 | -- | Multiply the given vector with the given scalar. | 36 | -- | Multiply the given vector with the given scalar. |
37 | scale :: Float -> a -> a | 37 | scale :: Float -> a -> a |
38 | 38 | ||
39 | -- | Negate the given vector. | 39 | -- | Negate the given vector. |
40 | neg :: a -> a | 40 | neg :: a -> a |
41 | 41 | ||
42 | -- | Normalise the given vector. | 42 | -- | Normalise the given vector. |
43 | normalise :: a -> a \ No newline at end of file | 43 | normalise :: a -> a \ No newline at end of file |
diff --git a/Spear/Math/Vector/Vector2.hs b/Spear/Math/Vector/Vector2.hs index 616d9dd..0b29ec4 100644 --- a/Spear/Math/Vector/Vector2.hs +++ b/Spear/Math/Vector/Vector2.hs | |||
@@ -1,130 +1,130 @@ | |||
1 | module Spear.Math.Vector.Vector2 | 1 | module Spear.Math.Vector.Vector2 |
2 | ( | 2 | ( |
3 | Vector2 | 3 | Vector2 |
4 | -- * Construction | 4 | -- * Construction |
5 | , unitx2 | 5 | , unitx2 |
6 | , unity2 | 6 | , unity2 |
7 | , zero2 | 7 | , zero2 |
8 | , vec2 | 8 | , vec2 |
9 | -- * Operations | 9 | -- * Operations |
10 | , perp | 10 | , perp |
11 | ) | 11 | ) |
12 | where | 12 | where |
13 | 13 | ||
14 | 14 | ||
15 | import Spear.Math.Vector.Class | 15 | import Spear.Math.Vector.Class |
16 | 16 | ||
17 | 17 | ||
18 | import Foreign.C.Types (CFloat) | 18 | import Foreign.C.Types (CFloat) |
19 | import Foreign.Storable | 19 | import Foreign.Storable |
20 | 20 | ||
21 | 21 | ||
22 | -- | Represents a vector in 2D. | 22 | -- | Represents a vector in 2D. |
23 | data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) | 23 | data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) |
24 | 24 | ||
25 | 25 | ||
26 | instance Num Vector2 where | 26 | instance Num Vector2 where |
27 | Vector2 ax ay + Vector2 bx by = Vector2 (ax + bx) (ay + by) | 27 | Vector2 ax ay + Vector2 bx by = Vector2 (ax + bx) (ay + by) |
28 | Vector2 ax ay - Vector2 bx by = Vector2 (ax - bx) (ay - by) | 28 | Vector2 ax ay - Vector2 bx by = Vector2 (ax - bx) (ay - by) |
29 | Vector2 ax ay * Vector2 bx by = Vector2 (ax * bx) (ay * by) | 29 | Vector2 ax ay * Vector2 bx by = Vector2 (ax * bx) (ay * by) |
30 | abs (Vector2 ax ay) = Vector2 (abs ax) (abs ay) | 30 | abs (Vector2 ax ay) = Vector2 (abs ax) (abs ay) |
31 | signum (Vector2 ax ay) = Vector2 (signum ax) (signum ay) | 31 | signum (Vector2 ax ay) = Vector2 (signum ax) (signum ay) |
32 | fromInteger i = Vector2 i' i' where i' = fromInteger i | 32 | fromInteger i = Vector2 i' i' where i' = fromInteger i |
33 | 33 | ||
34 | 34 | ||
35 | instance Fractional Vector2 where | 35 | instance Fractional Vector2 where |
36 | Vector2 ax ay / Vector2 bx by = Vector2 (ax / bx) (ay / by) | 36 | Vector2 ax ay / Vector2 bx by = Vector2 (ax / bx) (ay / by) |
37 | fromRational r = Vector2 r' r' where r' = fromRational r | 37 | fromRational r = Vector2 r' r' where r' = fromRational r |
38 | 38 | ||
39 | 39 | ||
40 | instance Ord Vector2 where | 40 | instance Ord Vector2 where |
41 | Vector2 ax ay <= Vector2 bx by = (ax <= bx) || (ax == bx && ay <= by) | 41 | 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) | 42 | Vector2 ax ay >= Vector2 bx by = (ax >= bx) || (ax == bx && ay >= by) |
43 | Vector2 ax ay < Vector2 bx by = (ax < bx) || (ax == bx && ay < by) | 43 | Vector2 ax ay < Vector2 bx by = (ax < bx) || (ax == bx && ay < by) |
44 | Vector2 ax ay > Vector2 bx by = (ax > bx) || (ax == bx && ay > by) | 44 | Vector2 ax ay > Vector2 bx by = (ax > bx) || (ax == bx && ay > by) |
45 | max (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.max ax bx) (Prelude.max ay by) | 45 | max (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.max ax bx) (Prelude.max ay by) |
46 | min (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.min ax bx) (Prelude.min ay by) | 46 | min (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.min ax bx) (Prelude.min ay by) |
47 | 47 | ||
48 | 48 | ||
49 | instance VectorClass Vector2 where | 49 | instance VectorClass Vector2 where |
50 | {-# INLINABLE fromList #-} | 50 | {-# INLINABLE fromList #-} |
51 | fromList (ax:ay:_) = Vector2 ax ay | 51 | fromList (ax:ay:_) = Vector2 ax ay |
52 | 52 | ||
53 | {-# INLINABLE x #-} | 53 | {-# INLINABLE x #-} |
54 | x (Vector2 ax _) = ax | 54 | x (Vector2 ax _) = ax |
55 | 55 | ||
56 | {-# INLINABLE y #-} | 56 | {-# INLINABLE y #-} |
57 | y (Vector2 _ ay) = ay | 57 | y (Vector2 _ ay) = ay |
58 | 58 | ||
59 | {-# INLINABLE (!) #-} | 59 | {-# INLINABLE (!) #-} |
60 | (Vector2 ax _) ! 0 = ax | 60 | (Vector2 ax _) ! 0 = ax |
61 | (Vector2 _ ay) ! 1 = ay | 61 | (Vector2 _ ay) ! 1 = ay |
62 | _ ! _ = 0 | 62 | _ ! _ = 0 |
63 | 63 | ||
64 | {-# INLINABLE dot #-} | 64 | {-# INLINABLE dot #-} |
65 | Vector2 ax ay `dot` Vector2 bx by = ax*bx + ay*by | 65 | Vector2 ax ay `dot` Vector2 bx by = ax*bx + ay*by |
66 | 66 | ||
67 | {-# INLINABLE normSq #-} | 67 | {-# INLINABLE normSq #-} |
68 | normSq (Vector2 ax ay) = ax*ax + ay*ay | 68 | normSq (Vector2 ax ay) = ax*ax + ay*ay |
69 | 69 | ||
70 | {-# INLINABLE norm #-} | 70 | {-# INLINABLE norm #-} |
71 | norm = sqrt . normSq | 71 | norm = sqrt . normSq |
72 | 72 | ||
73 | {-# INLINABLE scale #-} | 73 | {-# INLINABLE scale #-} |
74 | scale s (Vector2 ax ay) = Vector2 (s*ax) (s*ay) | 74 | scale s (Vector2 ax ay) = Vector2 (s*ax) (s*ay) |
75 | 75 | ||
76 | {-# INLINABLE neg #-} | 76 | {-# INLINABLE neg #-} |
77 | neg (Vector2 ax ay) = Vector2 (-ax) (-ay) | 77 | neg (Vector2 ax ay) = Vector2 (-ax) (-ay) |
78 | 78 | ||
79 | {-# INLINABLE normalise #-} | 79 | {-# INLINABLE normalise #-} |
80 | normalise v = | 80 | normalise v = |
81 | let n' = norm v | 81 | let n' = norm v |
82 | n = if n' == 0 then 1 else n' | 82 | n = if n' == 0 then 1 else n' |
83 | in scale (1.0 / n) v | 83 | in scale (1.0 / n) v |
84 | 84 | ||
85 | 85 | ||
86 | sizeFloat = sizeOf (undefined :: CFloat) | 86 | sizeFloat = sizeOf (undefined :: CFloat) |
87 | 87 | ||
88 | 88 | ||
89 | instance Storable Vector2 where | 89 | instance Storable Vector2 where |
90 | sizeOf _ = 2*sizeFloat | 90 | sizeOf _ = 2*sizeFloat |
91 | alignment _ = alignment (undefined :: CFloat) | 91 | alignment _ = alignment (undefined :: CFloat) |
92 | 92 | ||
93 | peek ptr = do | 93 | peek ptr = do |
94 | ax <- peekByteOff ptr 0 | 94 | ax <- peekByteOff ptr 0 |
95 | ay <- peekByteOff ptr $ sizeFloat | 95 | ay <- peekByteOff ptr $ sizeFloat |
96 | return (Vector2 ax ay) | 96 | return (Vector2 ax ay) |
97 | 97 | ||
98 | poke ptr (Vector2 ax ay) = do | 98 | poke ptr (Vector2 ax ay) = do |
99 | pokeByteOff ptr 0 ax | 99 | pokeByteOff ptr 0 ax |
100 | pokeByteOff ptr sizeFloat ay | 100 | pokeByteOff ptr sizeFloat ay |
101 | 101 | ||
102 | 102 | ||
103 | -- | Get the vector's x coordinate. | 103 | -- | Get the vector's x coordinate. |
104 | 104 | ||
105 | 105 | ||
106 | 106 | ||
107 | -- | Unit vector along the X axis. | 107 | -- | Unit vector along the X axis. |
108 | unitx2 = Vector2 1 0 | 108 | unitx2 = Vector2 1 0 |
109 | 109 | ||
110 | 110 | ||
111 | -- | Unit vector along the Y axis. | 111 | -- | Unit vector along the Y axis. |
112 | unity2 = Vector2 0 1 | 112 | unity2 = Vector2 0 1 |
113 | 113 | ||
114 | 114 | ||
115 | -- | Zero vector. | 115 | -- | Zero vector. |
116 | zero2 = Vector2 0 0 | 116 | zero2 = Vector2 0 0 |
117 | 117 | ||
118 | 118 | ||
119 | -- | Create a vector from the given values. | 119 | -- | Create a vector from the given values. |
120 | vec2 :: Float -> Float -> Vector2 | 120 | vec2 :: Float -> Float -> Vector2 |
121 | vec2 ax ay = Vector2 ax ay | 121 | vec2 ax ay = Vector2 ax ay |
122 | 122 | ||
123 | 123 | ||
124 | -- | Compute a vector perpendicular to the given one, satisfying: | 124 | -- | Compute a vector perpendicular to the given one, satisfying: |
125 | -- | 125 | -- |
126 | -- perp (Vector2 0 1) = Vector2 1 0 | 126 | -- perp (Vector2 0 1) = Vector2 1 0 |
127 | -- | 127 | -- |
128 | -- perp (Vector2 1 0) = Vector2 0 (-1) | 128 | -- perp (Vector2 1 0) = Vector2 0 (-1) |
129 | perp :: Vector2 -> Vector2 | 129 | perp :: Vector2 -> Vector2 |
130 | perp (Vector2 x y) = Vector2 y (-x) | 130 | perp (Vector2 x y) = Vector2 y (-x) |
diff --git a/Spear/Math/Vector/Vector3.hs b/Spear/Math/Vector/Vector3.hs index 8a1cfa9..70bd299 100644 --- a/Spear/Math/Vector/Vector3.hs +++ b/Spear/Math/Vector/Vector3.hs | |||
@@ -1,184 +1,184 @@ | |||
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 |
7 | , Position3 | 7 | , Position3 |
8 | -- * Construction | 8 | -- * Construction |
9 | , unitx3 | 9 | , unitx3 |
10 | , unity3 | 10 | , unity3 |
11 | , unitz3 | 11 | , unitz3 |
12 | , zero3 | 12 | , zero3 |
13 | , vec3 | 13 | , vec3 |
14 | , orbit | 14 | , orbit |
15 | -- * Operations | 15 | -- * Operations |
16 | , cross | 16 | , cross |
17 | ) | 17 | ) |
18 | where | 18 | where |
19 | 19 | ||
20 | 20 | ||
21 | import Spear.Math.Vector.Class | 21 | import Spear.Math.Vector.Class |
22 | 22 | ||
23 | import Foreign.C.Types (CFloat) | 23 | import Foreign.C.Types (CFloat) |
24 | import Foreign.Storable | 24 | import Foreign.Storable |
25 | 25 | ||
26 | type Right3 = Vector3 | 26 | type Right3 = Vector3 |
27 | type Up3 = Vector3 | 27 | type Up3 = Vector3 |
28 | type Forward3 = Vector3 | 28 | type Forward3 = Vector3 |
29 | type Position3 = Vector3 | 29 | type Position3 = Vector3 |
30 | 30 | ||
31 | 31 | ||
32 | -- | Represents a vector in 3D. | 32 | -- | Represents a vector in 3D. |
33 | data Vector3 = Vector3 | 33 | data Vector3 = Vector3 |
34 | {-# UNPACK #-} !Float | 34 | {-# UNPACK #-} !Float |
35 | {-# UNPACK #-} !Float | 35 | {-# UNPACK #-} !Float |
36 | {-# UNPACK #-} !Float | 36 | {-# UNPACK #-} !Float |
37 | deriving (Eq, Show) | 37 | deriving (Eq, Show) |
38 | 38 | ||
39 | instance Num Vector3 where | 39 | instance Num Vector3 where |
40 | Vector3 ax ay az + Vector3 bx by bz = Vector3 (ax + bx) (ay + by) (az + bz) | 40 | Vector3 ax ay az + Vector3 bx by bz = Vector3 (ax + bx) (ay + by) (az + bz) |
41 | Vector3 ax ay az - Vector3 bx by bz = Vector3 (ax - bx) (ay - by) (az - bz) | 41 | Vector3 ax ay az - Vector3 bx by bz = Vector3 (ax - bx) (ay - by) (az - bz) |
42 | Vector3 ax ay az * Vector3 bx by bz = Vector3 (ax * bx) (ay * by) (az * bz) | 42 | Vector3 ax ay az * Vector3 bx by bz = Vector3 (ax * bx) (ay * by) (az * bz) |
43 | abs (Vector3 ax ay az) = Vector3 (abs ax) (abs ay) (abs az) | 43 | abs (Vector3 ax ay az) = Vector3 (abs ax) (abs ay) (abs az) |
44 | signum (Vector3 ax ay az) = Vector3 (signum ax) (signum ay) (signum az) | 44 | signum (Vector3 ax ay az) = Vector3 (signum ax) (signum ay) (signum az) |
45 | fromInteger i = Vector3 i' i' i' where i' = fromInteger i | 45 | fromInteger i = Vector3 i' i' i' where i' = fromInteger i |
46 | 46 | ||
47 | 47 | ||
48 | instance Fractional Vector3 where | 48 | instance Fractional Vector3 where |
49 | Vector3 ax ay az / Vector3 bx by bz = Vector3 (ax / bx) (ay / by) (az / bz) | 49 | Vector3 ax ay az / Vector3 bx by bz = Vector3 (ax / bx) (ay / by) (az / bz) |
50 | fromRational r = Vector3 r' r' r' where r' = fromRational r | 50 | fromRational r = Vector3 r' r' r' where r' = fromRational r |
51 | 51 | ||
52 | 52 | ||
53 | instance Ord Vector3 where | 53 | instance Ord Vector3 where |
54 | Vector3 ax ay az <= Vector3 bx by bz | 54 | Vector3 ax ay az <= Vector3 bx by bz |
55 | = (ax <= bx) | 55 | = (ax <= bx) |
56 | || (az == bx && ay <= by) | 56 | || (az == bx && ay <= by) |
57 | || (ax == bx && ay == by && az <= bz) | 57 | || (ax == bx && ay == by && az <= bz) |
58 | 58 | ||
59 | Vector3 ax ay az >= Vector3 bx by bz | 59 | Vector3 ax ay az >= Vector3 bx by bz |
60 | = (ax >= bx) | 60 | = (ax >= bx) |
61 | || (ax == bx && ay >= by) | 61 | || (ax == bx && ay >= by) |
62 | || (ax == bx && ay == by && az >= bz) | 62 | || (ax == bx && ay == by && az >= bz) |
63 | 63 | ||
64 | Vector3 ax ay az < Vector3 bx by bz | 64 | Vector3 ax ay az < Vector3 bx by bz |
65 | = (ax < bx) | 65 | = (ax < bx) |
66 | || (az == bx && ay < by) | 66 | || (az == bx && ay < by) |
67 | || (ax == bx && ay == by && az < bz) | 67 | || (ax == bx && ay == by && az < bz) |
68 | 68 | ||
69 | Vector3 ax ay az > Vector3 bx by bz | 69 | Vector3 ax ay az > Vector3 bx by bz |
70 | = (ax > bx) | 70 | = (ax > bx) |
71 | || (ax == bx && ay > by) | 71 | || (ax == bx && ay > by) |
72 | || (ax == bx && ay == by && az > bz) | 72 | || (ax == bx && ay == by && az > bz) |
73 | 73 | ||
74 | max (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) | 74 | max (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) |
75 | 75 | ||
76 | min (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) | 76 | min (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) |
77 | 77 | ||
78 | 78 | ||
79 | instance VectorClass Vector3 where | 79 | instance VectorClass Vector3 where |
80 | {-# INLINABLE fromList #-} | 80 | {-# INLINABLE fromList #-} |
81 | fromList (ax:ay:az:_) = Vector3 ax ay az | 81 | fromList (ax:ay:az:_) = Vector3 ax ay az |
82 | 82 | ||
83 | {-# INLINABLE x #-} | 83 | {-# INLINABLE x #-} |
84 | x (Vector3 ax _ _ ) = ax | 84 | x (Vector3 ax _ _ ) = ax |
85 | 85 | ||
86 | {-# INLINABLE y #-} | 86 | {-# INLINABLE y #-} |
87 | y (Vector3 _ ay _ ) = ay | 87 | y (Vector3 _ ay _ ) = ay |
88 | 88 | ||
89 | {-# INLINABLE z #-} | 89 | {-# INLINABLE z #-} |
90 | z (Vector3 _ _ az) = az | 90 | z (Vector3 _ _ az) = az |
91 | 91 | ||
92 | {-# INLINABLE (!) #-} | 92 | {-# INLINABLE (!) #-} |
93 | (Vector3 ax _ _) ! 0 = ax | 93 | (Vector3 ax _ _) ! 0 = ax |
94 | (Vector3 _ ay _) ! 1 = ay | 94 | (Vector3 _ ay _) ! 1 = ay |
95 | (Vector3 _ _ az) ! 2 = az | 95 | (Vector3 _ _ az) ! 2 = az |
96 | _ ! _ = 0 | 96 | _ ! _ = 0 |
97 | 97 | ||
98 | {-# INLINABLE dot #-} | 98 | {-# INLINABLE dot #-} |
99 | Vector3 ax ay az `dot` Vector3 bx by bz = ax*bx + ay*by + az*bz | 99 | Vector3 ax ay az `dot` Vector3 bx by bz = ax*bx + ay*by + az*bz |
100 | 100 | ||
101 | {-# INLINABLE normSq #-} | 101 | {-# INLINABLE normSq #-} |
102 | normSq (Vector3 ax ay az) = ax*ax + ay*ay + az*az | 102 | normSq (Vector3 ax ay az) = ax*ax + ay*ay + az*az |
103 | 103 | ||
104 | {-# INLINABLE norm #-} | 104 | {-# INLINABLE norm #-} |
105 | norm = sqrt . normSq | 105 | norm = sqrt . normSq |
106 | 106 | ||
107 | {-# INLINABLE scale #-} | 107 | {-# INLINABLE scale #-} |
108 | scale s (Vector3 ax ay az) = Vector3 (s*ax) (s*ay) (s*az) | 108 | scale s (Vector3 ax ay az) = Vector3 (s*ax) (s*ay) (s*az) |
109 | 109 | ||
110 | {-# INLINABLE neg #-} | 110 | {-# INLINABLE neg #-} |
111 | neg (Vector3 ax ay az) = Vector3 (-ax) (-ay) (-az) | 111 | neg (Vector3 ax ay az) = Vector3 (-ax) (-ay) (-az) |
112 | 112 | ||
113 | {-# INLINABLE normalise #-} | 113 | {-# INLINABLE normalise #-} |
114 | normalise v = | 114 | normalise v = |
115 | let n' = norm v | 115 | let n' = norm v |
116 | n = if n' == 0 then 1 else n' | 116 | n = if n' == 0 then 1 else n' |
117 | in scale (1.0 / n) v | 117 | in scale (1.0 / n) v |
118 | 118 | ||
119 | 119 | ||
120 | sizeFloat = sizeOf (undefined :: CFloat) | 120 | sizeFloat = sizeOf (undefined :: CFloat) |
121 | 121 | ||
122 | 122 | ||
123 | instance Storable Vector3 where | 123 | instance Storable Vector3 where |
124 | sizeOf _ = 3*sizeFloat | 124 | sizeOf _ = 3*sizeFloat |
125 | alignment _ = alignment (undefined :: CFloat) | 125 | alignment _ = alignment (undefined :: CFloat) |
126 | 126 | ||
127 | peek ptr = do | 127 | peek ptr = do |
128 | ax <- peekByteOff ptr 0 | 128 | ax <- peekByteOff ptr 0 |
129 | ay <- peekByteOff ptr $ 1*sizeFloat | 129 | ay <- peekByteOff ptr $ 1*sizeFloat |
130 | az <- peekByteOff ptr $ 2*sizeFloat | 130 | az <- peekByteOff ptr $ 2*sizeFloat |
131 | return (Vector3 ax ay az) | 131 | return (Vector3 ax ay az) |
132 | 132 | ||
133 | poke ptr (Vector3 ax ay az) = do | 133 | poke ptr (Vector3 ax ay az) = do |
134 | pokeByteOff ptr 0 ax | 134 | pokeByteOff ptr 0 ax |
135 | pokeByteOff ptr (1*sizeFloat) ay | 135 | pokeByteOff ptr (1*sizeFloat) ay |
136 | pokeByteOff ptr (2*sizeFloat) az | 136 | pokeByteOff ptr (2*sizeFloat) az |
137 | 137 | ||
138 | 138 | ||
139 | -- | Unit vector along the X axis. | 139 | -- | Unit vector along the X axis. |
140 | unitx3 = Vector3 1 0 0 | 140 | unitx3 = Vector3 1 0 0 |
141 | 141 | ||
142 | 142 | ||
143 | -- | Unit vector along the Y axis. | 143 | -- | Unit vector along the Y axis. |
144 | unity3 = Vector3 0 1 0 | 144 | unity3 = Vector3 0 1 0 |
145 | 145 | ||
146 | 146 | ||
147 | -- | Unit vector along the Z axis. | 147 | -- | Unit vector along the Z axis. |
148 | unitz3 = Vector3 0 0 1 | 148 | unitz3 = Vector3 0 0 1 |
149 | 149 | ||
150 | 150 | ||
151 | -- | Zero vector. | 151 | -- | Zero vector. |
152 | zero3 = Vector3 0 0 0 | 152 | zero3 = Vector3 0 0 0 |
153 | 153 | ||
154 | 154 | ||
155 | -- | Create a 3D vector from the given values. | 155 | -- | Create a 3D vector from the given values. |
156 | vec3 :: Float -> Float -> Float -> Vector3 | 156 | vec3 :: Float -> Float -> Float -> Vector3 |
157 | vec3 ax ay az = Vector3 ax ay az | 157 | vec3 ax ay az = Vector3 ax ay az |
158 | 158 | ||
159 | 159 | ||
160 | -- | Create a 3D vector as a point on a sphere. | 160 | -- | Create a 3D vector as a point on a sphere. |
161 | orbit :: Vector3 -- ^ Sphere center. | 161 | orbit :: Vector3 -- ^ Sphere center. |
162 | -> Float -- ^ Sphere radius | 162 | -> Float -- ^ Sphere radius |
163 | -> Float -- ^ Azimuth angle. | 163 | -> Float -- ^ Azimuth angle. |
164 | -> Float -- ^ Zenith angle. | 164 | -> Float -- ^ Zenith angle. |
165 | -> Vector3 | 165 | -> Vector3 |
166 | 166 | ||
167 | orbit center radius anglex angley = | 167 | orbit center radius anglex angley = |
168 | let ax = anglex * pi / 180 | 168 | let ax = anglex * pi / 180 |
169 | ay = angley * pi / 180 | 169 | ay = angley * pi / 180 |
170 | sx = sin ax | 170 | sx = sin ax |
171 | sy = sin ay | 171 | sy = sin ay |
172 | cx = cos ax | 172 | cx = cos ax |
173 | cy = cos ay | 173 | cy = cos ay |
174 | px = x center + radius*cy*sx | 174 | px = x center + radius*cy*sx |
175 | py = y center + radius*sy | 175 | py = y center + radius*sy |
176 | pz = z center + radius*cx*cy | 176 | pz = z center + radius*cx*cy |
177 | in | 177 | in |
178 | vec3 px py pz | 178 | vec3 px py pz |
179 | 179 | ||
180 | 180 | ||
181 | -- | Compute the given vectors' cross product. | 181 | -- | Compute the given vectors' cross product. |
182 | cross :: Vector3 -> Vector3 -> Vector3 | 182 | cross :: Vector3 -> Vector3 -> Vector3 |
183 | (Vector3 ax ay az) `cross` (Vector3 bx by bz) = | 183 | (Vector3 ax ay az) `cross` (Vector3 bx by bz) = |
184 | Vector3 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx) | 184 | Vector3 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx) |
diff --git a/Spear/Math/Vector/Vector4.hs b/Spear/Math/Vector/Vector4.hs index 5185763..3b5ed95 100644 --- a/Spear/Math/Vector/Vector4.hs +++ b/Spear/Math/Vector/Vector4.hs | |||
@@ -1,166 +1,166 @@ | |||
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 |
7 | , unitz4 | 7 | , unitz4 |
8 | , vec4 | 8 | , vec4 |
9 | -- * Operations | 9 | -- * Operations |
10 | , cross' | 10 | , cross' |
11 | ) | 11 | ) |
12 | where | 12 | where |
13 | 13 | ||
14 | 14 | ||
15 | import Spear.Math.Vector.Class | 15 | import Spear.Math.Vector.Class |
16 | 16 | ||
17 | import Foreign.C.Types (CFloat) | 17 | import Foreign.C.Types (CFloat) |
18 | import Foreign.Storable | 18 | import Foreign.Storable |
19 | 19 | ||
20 | 20 | ||
21 | -- | Represents a vector in 3D. | 21 | -- | Represents a vector in 3D. |
22 | data Vector4 = Vector4 | 22 | data Vector4 = Vector4 |
23 | {-# UNPACK #-} !Float | 23 | {-# UNPACK #-} !Float |
24 | {-# UNPACK #-} !Float | 24 | {-# UNPACK #-} !Float |
25 | {-# UNPACK #-} !Float | 25 | {-# UNPACK #-} !Float |
26 | {-# UNPACK #-} !Float | 26 | {-# UNPACK #-} !Float |
27 | deriving (Eq, Show) | 27 | deriving (Eq, Show) |
28 | 28 | ||
29 | 29 | ||
30 | instance Num Vector4 where | 30 | instance Num Vector4 where |
31 | Vector4 ax ay az aw + Vector4 bx by bz bw = Vector4 (ax + bx) (ay + by) (az + bz) (aw + bw) | 31 | Vector4 ax ay az aw + Vector4 bx by bz bw = Vector4 (ax + bx) (ay + by) (az + bz) (aw + bw) |
32 | Vector4 ax ay az aw - Vector4 bx by bz bw = Vector4 (ax - bx) (ay - by) (az - bz) (aw - bw) | 32 | Vector4 ax ay az aw - Vector4 bx by bz bw = Vector4 (ax - bx) (ay - by) (az - bz) (aw - bw) |
33 | Vector4 ax ay az aw * Vector4 bx by bz bw = Vector4 (ax * bx) (ay * by) (az * bz) (aw * bw) | 33 | Vector4 ax ay az aw * Vector4 bx by bz bw = Vector4 (ax * bx) (ay * by) (az * bz) (aw * bw) |
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) |
66 | || (ax == bx && ay == by && az > bz) | 66 | || (ax == bx && ay == by && az > bz) |
67 | || (ax == bx && ay == by && az == bz && aw > bw) | 67 | || (ax == bx && ay == by && az == bz && aw > bw) |
68 | 68 | ||
69 | min (Vector4 ax ay az aw) (Vector4 bx by bz bw) = | 69 | min (Vector4 ax ay az aw) (Vector4 bx by bz bw) = |
70 | Vector4 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) (Prelude.min aw bw) | 70 | Vector4 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) (Prelude.min aw bw) |
71 | 71 | ||
72 | max (Vector4 ax ay az aw) (Vector4 bx by bz bw) = | 72 | max (Vector4 ax ay az aw) (Vector4 bx by bz bw) = |
73 | Vector4 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) (Prelude.min aw bw) | 73 | Vector4 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) (Prelude.min aw bw) |
74 | 74 | ||
75 | 75 | ||
76 | instance VectorClass Vector4 where | 76 | instance VectorClass Vector4 where |
77 | {-# INLINABLE fromList #-} | 77 | {-# INLINABLE fromList #-} |
78 | fromList (ax:ay:az:aw:_) = Vector4 ax ay az aw | 78 | fromList (ax:ay:az:aw:_) = Vector4 ax ay az aw |
79 | 79 | ||
80 | {-# INLINABLE x #-} | 80 | {-# INLINABLE x #-} |
81 | x (Vector4 ax _ _ _ ) = ax | 81 | x (Vector4 ax _ _ _ ) = ax |
82 | 82 | ||
83 | {-# INLINABLE y #-} | 83 | {-# INLINABLE y #-} |
84 | y (Vector4 _ ay _ _ ) = ay | 84 | y (Vector4 _ ay _ _ ) = ay |
85 | 85 | ||
86 | {-# INLINABLE z #-} | 86 | {-# INLINABLE z #-} |
87 | z (Vector4 _ _ az _ ) = az | 87 | z (Vector4 _ _ az _ ) = az |
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 |
117 | n = if n' == 0 then 1 else n' | 117 | n = if n' == 0 then 1 else n' |
118 | in scale (1.0 / n) v | 118 | in scale (1.0 / n) v |
119 | 119 | ||
120 | 120 | ||
121 | sizeFloat = sizeOf (undefined :: CFloat) | 121 | sizeFloat = sizeOf (undefined :: CFloat) |
122 | 122 | ||
123 | 123 | ||
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 |
138 | pokeByteOff ptr (2 * sizeFloat) az | 138 | pokeByteOff ptr (2 * sizeFloat) az |
139 | pokeByteOff ptr (3 * sizeFloat) aw | 139 | pokeByteOff ptr (3 * sizeFloat) aw |
140 | 140 | ||
141 | 141 | ||
142 | -- | Unit vector along the X axis. | 142 | -- | Unit vector along the X axis. |
143 | unitx4 = Vector4 1 0 0 0 | 143 | unitx4 = Vector4 1 0 0 0 |
144 | 144 | ||
145 | 145 | ||
146 | -- | Unit vector along the Y axis. | 146 | -- | Unit vector along the Y axis. |
147 | unity4 = Vector4 0 1 0 0 | 147 | unity4 = Vector4 0 1 0 0 |
148 | 148 | ||
149 | 149 | ||
150 | -- | Unit vector along the Z axis. | 150 | -- | Unit vector along the Z axis. |
151 | unitz4 = Vector4 0 0 1 0 | 151 | unitz4 = Vector4 0 0 1 0 |
152 | 152 | ||
153 | -- | Unit vector along the W axis. | 153 | -- | Unit vector along the W axis. |
154 | unitw4 = Vector4 0 0 0 1 | 154 | unitw4 = Vector4 0 0 0 1 |
155 | 155 | ||
156 | 156 | ||
157 | -- | Create a 4D vector from the given values. | 157 | -- | Create a 4D vector from the given values. |
158 | vec4 :: Float -> Float -> Float -> Float -> Vector4 | 158 | vec4 :: Float -> Float -> Float -> Float -> Vector4 |
159 | vec4 ax ay az aw = Vector4 ax ay az aw | 159 | vec4 ax ay az aw = Vector4 ax ay az aw |
160 | 160 | ||
161 | 161 | ||
162 | -- | Compute the given vectors' cross product. | 162 | -- | Compute the given vectors' cross product. |
163 | -- The vectors are projected to 3D space. The resulting vector is the cross product of the vectors' projections with w=0. | 163 | -- The vectors are projected to 3D space. The resulting vector is the cross product of the vectors' projections with w=0. |
164 | cross' :: Vector4 -> Vector4 -> Vector4 | 164 | cross' :: Vector4 -> Vector4 -> Vector4 |
165 | (Vector4 ax ay az _) `cross'` (Vector4 bx by bz _) = | 165 | (Vector4 ax ay az _) `cross'` (Vector4 bx by bz _) = |
166 | Vector4 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx) 0 | 166 | Vector4 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx) 0 |
diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs index c2456b2..c31c18a 100644 --- a/Spear/Render/AnimatedModel.hs +++ b/Spear/Render/AnimatedModel.hs | |||
@@ -1,235 +1,235 @@ | |||
1 | module Spear.Render.AnimatedModel | 1 | module Spear.Render.AnimatedModel |
2 | ( | 2 | ( |
3 | -- * Data types | 3 | -- * Data types |
4 | AnimatedModelResource | 4 | AnimatedModelResource |
5 | , AnimatedModelRenderer | 5 | , AnimatedModelRenderer |
6 | , AnimationSpeed | 6 | , AnimationSpeed |
7 | -- * Construction and destruction | 7 | -- * Construction and destruction |
8 | , animatedModelResource | 8 | , animatedModelResource |
9 | , animatedModelRenderer | 9 | , animatedModelRenderer |
10 | -- * Accessors | 10 | -- * Accessors |
11 | , animationSpeed | 11 | , animationSpeed |
12 | , box | 12 | , box |
13 | , currentAnimation | 13 | , currentAnimation |
14 | , currentFrame | 14 | , currentFrame |
15 | , frameProgress | 15 | , frameProgress |
16 | , modelRes | 16 | , modelRes |
17 | , nextFrame | 17 | , nextFrame |
18 | -- * Manipulation | 18 | -- * Manipulation |
19 | , update | 19 | , update |
20 | , setAnimation | 20 | , setAnimation |
21 | , setAnimationSpeed | 21 | , setAnimationSpeed |
22 | -- * Rendering | 22 | -- * Rendering |
23 | , bind | 23 | , bind |
24 | , render | 24 | , render |
25 | -- * Collision | 25 | -- * Collision |
26 | , mkColsFromAnimated | 26 | , mkColsFromAnimated |
27 | ) | 27 | ) |
28 | where | 28 | where |
29 | 29 | ||
30 | import Spear.Assets.Model | 30 | import Spear.Assets.Model |
31 | import Spear.Game | 31 | import Spear.Game |
32 | import Spear.GL | 32 | import Spear.GL |
33 | import Spear.Math.AABB | 33 | import Spear.Math.AABB |
34 | import Spear.Math.Collision | 34 | import Spear.Math.Collision |
35 | import Spear.Math.Matrix4 (Matrix4) | 35 | import Spear.Math.Matrix4 (Matrix4) |
36 | import Spear.Math.Vector | 36 | import Spear.Math.Vector |
37 | import Spear.Render.Material | 37 | import Spear.Render.Material |
38 | import Spear.Render.Model | 38 | import Spear.Render.Model |
39 | import Spear.Render.Program | 39 | import Spear.Render.Program |
40 | 40 | ||
41 | import Control.Applicative ((<$>), (<*>)) | 41 | import Control.Applicative ((<$>), (<*>)) |
42 | import qualified Data.Vector as V | 42 | import qualified Data.Vector as V |
43 | import Unsafe.Coerce (unsafeCoerce) | 43 | import Unsafe.Coerce (unsafeCoerce) |
44 | 44 | ||
45 | type AnimationSpeed = Float | 45 | type AnimationSpeed = Float |
46 | 46 | ||
47 | -- | An animated model resource. | 47 | -- | An animated model resource. |
48 | -- | 48 | -- |
49 | -- Contains model data necessary to render an animated model. | 49 | -- Contains model data necessary to render an animated model. |
50 | data AnimatedModelResource = AnimatedModelResource | 50 | data AnimatedModelResource = AnimatedModelResource |
51 | { model :: Model | 51 | { model :: Model |
52 | , vao :: VAO | 52 | , vao :: VAO |
53 | , nFrames :: Int | 53 | , nFrames :: Int |
54 | , nVertices :: Int | 54 | , nVertices :: Int |
55 | , material :: Material | 55 | , material :: Material |
56 | , texture :: Texture | 56 | , texture :: Texture |
57 | , boxes :: V.Vector Box | 57 | , boxes :: V.Vector Box |
58 | , rkey :: Resource | 58 | , rkey :: Resource |
59 | } | 59 | } |
60 | 60 | ||
61 | instance Eq AnimatedModelResource where | 61 | instance Eq AnimatedModelResource where |
62 | m1 == m2 = vao m1 == vao m2 | 62 | m1 == m2 = vao m1 == vao m2 |
63 | 63 | ||
64 | instance Ord AnimatedModelResource where | 64 | instance Ord AnimatedModelResource where |
65 | m1 < m2 = vao m1 < vao m2 | 65 | m1 < m2 = vao m1 < vao m2 |
66 | 66 | ||
67 | instance ResourceClass AnimatedModelResource where | 67 | instance ResourceClass AnimatedModelResource where |
68 | getResource = rkey | 68 | getResource = rkey |
69 | 69 | ||
70 | -- | An animated model renderer. | 70 | -- | An animated model renderer. |
71 | -- | 71 | -- |
72 | -- Holds animation data necessary to render an animated model and a reference | 72 | -- Holds animation data necessary to render an animated model and a reference |
73 | -- to an 'AnimatedModelResource'. | 73 | -- to an 'AnimatedModelResource'. |
74 | -- | 74 | -- |
75 | -- Model data is kept separate from animation data. This allows instances | 75 | -- Model data is kept separate from animation data. This allows instances |
76 | -- of 'AnimatedModelRenderer' to share the underlying 'AnimatedModelResource', | 76 | -- of 'AnimatedModelRenderer' to share the underlying 'AnimatedModelResource', |
77 | -- minimising the amount of data in memory and allowing one to minimise OpenGL | 77 | -- minimising the amount of data in memory and allowing one to minimise OpenGL |
78 | -- state changes by sorting 'AnimatedModelRenderer's by their underlying | 78 | -- state changes by sorting 'AnimatedModelRenderer's by their underlying |
79 | -- 'AnimatedModelResource' when rendering the scene. | 79 | -- 'AnimatedModelResource' when rendering the scene. |
80 | data AnimatedModelRenderer = AnimatedModelRenderer | 80 | data AnimatedModelRenderer = AnimatedModelRenderer |
81 | { modelResource :: AnimatedModelResource | 81 | { modelResource :: AnimatedModelResource |
82 | , currentAnim :: Int | 82 | , currentAnim :: Int |
83 | , frameStart :: Int | 83 | , frameStart :: Int |
84 | , frameEnd :: Int | 84 | , frameEnd :: Int |
85 | , currentFrame :: Int -- ^ Get the renderer's current frame. | 85 | , currentFrame :: Int -- ^ Get the renderer's current frame. |
86 | , frameProgress :: Float -- ^ Get the renderer's frame progress. | 86 | , frameProgress :: Float -- ^ Get the renderer's frame progress. |
87 | , animationSpeed :: Float -- ^ Get the renderer's animation speed. | 87 | , animationSpeed :: Float -- ^ Get the renderer's animation speed. |
88 | } | 88 | } |
89 | 89 | ||
90 | instance Eq AnimatedModelRenderer where | 90 | instance Eq AnimatedModelRenderer where |
91 | m1 == m2 = modelResource m1 == modelResource m2 | 91 | m1 == m2 = modelResource m1 == modelResource m2 |
92 | 92 | ||
93 | instance Ord AnimatedModelRenderer where | 93 | instance Ord AnimatedModelRenderer where |
94 | m1 < m2 = modelResource m1 < modelResource m2 | 94 | m1 < m2 = modelResource m1 < modelResource m2 |
95 | 95 | ||
96 | -- | Create an model resource from the given model. | 96 | -- | Create an model resource from the given model. |
97 | animatedModelResource :: AnimatedProgramChannels | 97 | animatedModelResource :: AnimatedProgramChannels |
98 | -> Material | 98 | -> Material |
99 | -> Texture | 99 | -> Texture |
100 | -> Model | 100 | -> Model |
101 | -> Game s AnimatedModelResource | 101 | -> Game s AnimatedModelResource |
102 | 102 | ||
103 | animatedModelResource | 103 | animatedModelResource |
104 | (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan) | 104 | (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan) |
105 | material texture model = do | 105 | material texture model = do |
106 | RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model | 106 | RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model |
107 | elementBuf <- newBuffer | 107 | elementBuf <- newBuffer |
108 | vao <- newVAO | 108 | vao <- newVAO |
109 | boxes <- gameIO $ modelBoxes model | 109 | boxes <- gameIO $ modelBoxes model |
110 | 110 | ||
111 | gameIO $ do | 111 | gameIO $ do |
112 | 112 | ||
113 | let elemSize = 56 | 113 | let elemSize = 56 |
114 | elemSize' = fromIntegral elemSize | 114 | elemSize' = fromIntegral elemSize |
115 | n = numVertices * numFrames | 115 | n = numVertices * numFrames |
116 | 116 | ||
117 | bindVAO vao | 117 | bindVAO vao |
118 | 118 | ||
119 | bindBuffer elementBuf ArrayBuffer | 119 | bindBuffer ArrayBuffer elementBuf |
120 | bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw | 120 | bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw |
121 | 121 | ||
122 | attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0 | 122 | attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0 |
123 | attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12 | 123 | attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12 |
124 | attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24 | 124 | attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24 |
125 | attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36 | 125 | attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36 |
126 | attribVAOPointer texChan 2 gl_FLOAT False elemSize' 48 | 126 | attribVAOPointer texChan 2 gl_FLOAT False elemSize' 48 |
127 | 127 | ||
128 | enableVAOAttrib vertChan1 | 128 | enableVAOAttrib vertChan1 |
129 | enableVAOAttrib vertChan2 | 129 | enableVAOAttrib vertChan2 |
130 | enableVAOAttrib normChan1 | 130 | enableVAOAttrib normChan1 |
131 | enableVAOAttrib normChan2 | 131 | enableVAOAttrib normChan2 |
132 | enableVAOAttrib texChan | 132 | enableVAOAttrib texChan |
133 | 133 | ||
134 | rkey <- register $ do | 134 | rkey <- register $ do |
135 | putStrLn "Releasing animated model resource" | 135 | putStrLn "Releasing animated model resource" |
136 | clean vao | 136 | clean vao |
137 | clean elementBuf | 137 | clean elementBuf |
138 | 138 | ||
139 | return $ AnimatedModelResource | 139 | return $ AnimatedModelResource |
140 | model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices) | 140 | model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices) |
141 | material texture boxes rkey | 141 | material texture boxes rkey |
142 | 142 | ||
143 | -- | Create a renderer from the given model resource. | 143 | -- | Create a renderer from the given model resource. |
144 | animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer | 144 | animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer |
145 | animatedModelRenderer animSpeed modelResource = | 145 | animatedModelRenderer animSpeed modelResource = |
146 | AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed | 146 | AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed |
147 | 147 | ||
148 | -- | Update the renderer. | 148 | -- | Update the renderer. |
149 | update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = | 149 | update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = |
150 | AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s | 150 | AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s |
151 | where f = fp + dt * s | 151 | where f = fp + dt * s |
152 | nextFrame = f >= 1.0 | 152 | nextFrame = f >= 1.0 |
153 | fp' = if nextFrame then f - 1.0 else f | 153 | fp' = if nextFrame then f - 1.0 else f |
154 | curFrame' = if nextFrame | 154 | curFrame' = if nextFrame |
155 | then let x = curFrame + 1 | 155 | then let x = curFrame + 1 |
156 | in if x > endFrame then startFrame else x | 156 | in if x > endFrame then startFrame else x |
157 | else curFrame | 157 | else curFrame |
158 | 158 | ||
159 | -- | Get the model's ith bounding box. | 159 | -- | Get the model's ith bounding box. |
160 | box :: Int -> AnimatedModelResource -> Box | 160 | box :: Int -> AnimatedModelResource -> Box |
161 | box i model = boxes model V.! i | 161 | box i model = boxes model V.! i |
162 | 162 | ||
163 | -- | Get the renderer's current animation. | 163 | -- | Get the renderer's current animation. |
164 | currentAnimation :: Enum a => AnimatedModelRenderer -> a | 164 | currentAnimation :: Enum a => AnimatedModelRenderer -> a |
165 | currentAnimation = toEnum . currentAnim | 165 | currentAnimation = toEnum . currentAnim |
166 | 166 | ||
167 | -- | Get the renderer's model resource. | 167 | -- | Get the renderer's model resource. |
168 | modelRes :: AnimatedModelRenderer -> AnimatedModelResource | 168 | modelRes :: AnimatedModelRenderer -> AnimatedModelResource |
169 | modelRes = modelResource | 169 | modelRes = modelResource |
170 | 170 | ||
171 | -- | Get the renderer's next frame. | 171 | -- | Get the renderer's next frame. |
172 | nextFrame :: AnimatedModelRenderer -> Int | 172 | nextFrame :: AnimatedModelRenderer -> Int |
173 | nextFrame rend = | 173 | nextFrame rend = |
174 | let curFrame = currentFrame rend | 174 | let curFrame = currentFrame rend |
175 | in | 175 | in |
176 | if curFrame == frameEnd rend | 176 | if curFrame == frameEnd rend |
177 | then frameStart rend | 177 | then frameStart rend |
178 | else curFrame + 1 | 178 | else curFrame + 1 |
179 | 179 | ||
180 | -- | Set the active animation to the given one. | 180 | -- | Set the active animation to the given one. |
181 | setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer | 181 | setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer |
182 | setAnimation anim modelRend = | 182 | setAnimation anim modelRend = |
183 | let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim' | 183 | let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim' |
184 | anim' = fromEnum anim | 184 | anim' = fromEnum anim |
185 | in | 185 | in |
186 | modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 } | 186 | modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 } |
187 | 187 | ||
188 | -- | Set the renderer's animation speed. | 188 | -- | Set the renderer's animation speed. |
189 | setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer | 189 | setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer |
190 | setAnimationSpeed s r = r { animationSpeed = s } | 190 | setAnimationSpeed s r = r { animationSpeed = s } |
191 | 191 | ||
192 | -- | Bind the given renderer to prepare it for rendering. | 192 | -- | Bind the given renderer to prepare it for rendering. |
193 | bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () | 193 | bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () |
194 | bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = | 194 | bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = |
195 | let model' = modelResource modelRend | 195 | let model' = modelResource modelRend |
196 | in do | 196 | in do |
197 | bindVAO . vao $ model' | 197 | bindVAO . vao $ model' |
198 | bindTexture $ texture model' | 198 | bindTexture $ texture model' |
199 | activeTexture $= gl_TEXTURE0 | 199 | activeTexture $= gl_TEXTURE0 |
200 | glUniform1i texLoc 0 | 200 | glUniform1i texLoc 0 |
201 | 201 | ||
202 | -- | Render the model described by the given renderer. | 202 | -- | Render the model described by the given renderer. |
203 | render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () | 203 | render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () |
204 | render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = | 204 | render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = |
205 | let n = nVertices model | 205 | let n = nVertices model |
206 | (Material _ ka kd ks shi) = material model | 206 | (Material _ ka kd ks shi) = material model |
207 | in do | 207 | in do |
208 | uniform (kaLoc uniforms) ka | 208 | uniform (kaLoc uniforms) ka |
209 | uniform (kdLoc uniforms) kd | 209 | uniform (kdLoc uniforms) kd |
210 | uniform (ksLoc uniforms) ks | 210 | uniform (ksLoc uniforms) ks |
211 | glUniform1f (shiLoc uniforms) $ unsafeCoerce shi | 211 | glUniform1f (shiLoc uniforms) $ unsafeCoerce shi |
212 | glUniform1f (fpLoc uniforms) (unsafeCoerce fp) | 212 | glUniform1f (fpLoc uniforms) (unsafeCoerce fp) |
213 | drawArrays gl_TRIANGLES (n*curFrame) n | 213 | drawArrays gl_TRIANGLES (n*curFrame) n |
214 | 214 | ||
215 | -- | Compute AABB collisioners in view space from the given model. | 215 | -- | Compute AABB collisioners in view space from the given model. |
216 | mkColsFromAnimated | 216 | mkColsFromAnimated |
217 | :: Int -- ^ Source frame | 217 | :: Int -- ^ Source frame |
218 | -> Int -- ^ Dest frame | 218 | -> Int -- ^ Dest frame |
219 | -> Float -- ^ Frame progress | 219 | -> Float -- ^ Frame progress |
220 | -> Matrix4 -- ^ Modelview matrix | 220 | -> Matrix4 -- ^ Modelview matrix |
221 | -> AnimatedModelResource | 221 | -> AnimatedModelResource |
222 | -> [Collisioner2] | 222 | -> [Collisioner2] |
223 | mkColsFromAnimated f1 f2 fp modelview modelRes = | 223 | mkColsFromAnimated f1 f2 fp modelview modelRes = |
224 | let | 224 | let |
225 | (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes | 225 | (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes |
226 | (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes | 226 | (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes |
227 | min1 = vec3 xmin1 ymin1 zmin1 | 227 | min1 = vec3 xmin1 ymin1 zmin1 |
228 | max1 = vec3 xmax1 ymax1 zmax1 | 228 | max1 = vec3 xmax1 ymax1 zmax1 |
229 | min2 = vec3 xmin2 ymin2 zmin2 | 229 | min2 = vec3 xmin2 ymin2 zmin2 |
230 | max2 = vec3 xmax2 ymax2 zmax2 | 230 | max2 = vec3 xmax2 ymax2 zmax2 |
231 | min = min1 + scale fp (min2 - min1) | 231 | min = min1 + scale fp (min2 - min1) |
232 | max = max1 + scale fp (max2 - max1) | 232 | max = max1 + scale fp (max2 - max1) |
233 | in | 233 | in |
234 | mkCols modelview | 234 | mkCols modelview |
235 | $ Box (Vec3 (x min) (y min) (z min)) (Vec3 (x max) (y max) (z max)) | 235 | $ Box (Vec3 (x min) (y min) (z min)) (Vec3 (x max) (y max) (z max)) |
diff --git a/Spear/Render/Box.hs b/Spear/Render/Box.hs index 5da6fa8..305ef32 100644 --- a/Spear/Render/Box.hs +++ b/Spear/Render/Box.hs | |||
@@ -1,193 +1,193 @@ | |||
1 | module Spear.Render.Box | 1 | module Spear.Render.Box |
2 | ( | 2 | ( |
3 | render | 3 | render |
4 | , renderOutwards | 4 | , renderOutwards |
5 | , renderInwards | 5 | , renderInwards |
6 | , renderEdges | 6 | , renderEdges |
7 | ) | 7 | ) |
8 | where | 8 | where |
9 | 9 | ||
10 | 10 | ||
11 | import Spear.Math.Vector3 | 11 | import Spear.Math.Vector3 |
12 | import Spear.Math.Matrix | 12 | import Spear.Math.Matrix |
13 | import Graphics.Rendering.OpenGL.Raw | 13 | import Graphics.Rendering.OpenGL.Raw |
14 | import Unsafe.Coerce | 14 | import Unsafe.Coerce |
15 | import Control.Monad.Instances | 15 | import Control.Monad.Instances |
16 | 16 | ||
17 | type Center = Vector3 | 17 | type Center = Vector3 |
18 | type Colour = Vector4 | 18 | type Colour = Vector4 |
19 | type Length = Float | 19 | type Length = Float |
20 | type Normals = [Vector3] | 20 | type Normals = [Vector3] |
21 | type GenerateTexCoords = Bool | 21 | type GenerateTexCoords = Bool |
22 | 22 | ||
23 | 23 | ||
24 | applyColour :: Colour -> IO () | 24 | applyColour :: Colour -> IO () |
25 | --applyColour col = glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) (unsafeCoerce $ w col) | 25 | --applyColour col = glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) (unsafeCoerce $ w col) |
26 | applyColour = do | 26 | applyColour = do |
27 | ax <- unsafeCoerce . x | 27 | ax <- unsafeCoerce . x |
28 | ay <- unsafeCoerce . y | 28 | ay <- unsafeCoerce . y |
29 | az <- unsafeCoerce . z | 29 | az <- unsafeCoerce . z |
30 | aw <- unsafeCoerce . w | 30 | aw <- unsafeCoerce . w |
31 | glColor4f ax ay az aw | 31 | glColor4f ax ay az aw |
32 | 32 | ||
33 | 33 | ||
34 | applyNormal :: Vector3 -> IO () | 34 | applyNormal :: Vector3 -> IO () |
35 | --applyNormal v = glNormal3f (unsafeCoerce $ x v) (unsafeCoerce $ y v) (unsafeCoerce $ z v) | 35 | --applyNormal v = glNormal3f (unsafeCoerce $ x v) (unsafeCoerce $ y v) (unsafeCoerce $ z v) |
36 | applyNormal = do | 36 | applyNormal = do |
37 | nx <- unsafeCoerce . x | 37 | nx <- unsafeCoerce . x |
38 | ny <- unsafeCoerce . y | 38 | ny <- unsafeCoerce . y |
39 | nz <- unsafeCoerce . z | 39 | nz <- unsafeCoerce . z |
40 | glNormal3f nx ny nz | 40 | glNormal3f nx ny nz |
41 | 41 | ||
42 | 42 | ||
43 | -- | Renders a box. | 43 | -- | Renders a box. |
44 | render :: Center -- ^ The box's center. | 44 | render :: Center -- ^ The box's center. |
45 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. | 45 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. |
46 | -> Colour -- ^ The box's colour. | 46 | -> Colour -- ^ The box's colour. |
47 | -> Normals -- ^ The box's normals, of the form [front, back, right, left, top, bottom]. | 47 | -> Normals -- ^ The box's normals, of the form [front, back, right, left, top, bottom]. |
48 | -> IO () | 48 | -> IO () |
49 | render c l col normals = do | 49 | render c l col normals = do |
50 | glPushMatrix | 50 | glPushMatrix |
51 | glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) | 51 | glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) |
52 | applyColour col | 52 | applyColour col |
53 | 53 | ||
54 | let d = unsafeCoerce l | 54 | let d = unsafeCoerce l |
55 | glBegin gl_QUADS | 55 | glBegin gl_QUADS |
56 | 56 | ||
57 | --Front | 57 | --Front |
58 | --glNormal3f 0 0 (-1) | 58 | --glNormal3f 0 0 (-1) |
59 | applyNormal $ normals !! 0 | 59 | applyNormal $ normals !! 0 |
60 | glVertex3f d (-d) (-d) | 60 | glVertex3f d (-d) (-d) |
61 | glVertex3f d d (-d) | 61 | glVertex3f d d (-d) |
62 | glVertex3f (-d) d (-d) | 62 | glVertex3f (-d) d (-d) |
63 | glVertex3f (-d) (-d) (-d) | 63 | glVertex3f (-d) (-d) (-d) |
64 | 64 | ||
65 | --Back | 65 | --Back |
66 | --glNormal3f 0 0 1 | 66 | --glNormal3f 0 0 1 |
67 | applyNormal $ normals !! 1 | 67 | applyNormal $ normals !! 1 |
68 | glVertex3f (-d) (-d) d | 68 | glVertex3f (-d) (-d) d |
69 | glVertex3f (-d) d d | 69 | glVertex3f (-d) d d |
70 | glVertex3f d d d | 70 | glVertex3f d d d |
71 | glVertex3f d (-d) d | 71 | glVertex3f d (-d) d |
72 | 72 | ||
73 | --Right | 73 | --Right |
74 | --glNormal3f 1 0 0 | 74 | --glNormal3f 1 0 0 |
75 | applyNormal $ normals !! 2 | 75 | applyNormal $ normals !! 2 |
76 | glVertex3f d (-d) (-d) | 76 | glVertex3f d (-d) (-d) |
77 | glVertex3f d (-d) d | 77 | glVertex3f d (-d) d |
78 | glVertex3f d d d | 78 | glVertex3f d d d |
79 | glVertex3f d d (-d) | 79 | glVertex3f d d (-d) |
80 | 80 | ||
81 | --Left | 81 | --Left |
82 | --glNormal3f (-1) 0 0 | 82 | --glNormal3f (-1) 0 0 |
83 | applyNormal $ normals !! 3 | 83 | applyNormal $ normals !! 3 |
84 | glVertex3f (-d) (-d) (-d) | 84 | glVertex3f (-d) (-d) (-d) |
85 | glVertex3f (-d) d (-d) | 85 | glVertex3f (-d) d (-d) |
86 | glVertex3f (-d) d d | 86 | glVertex3f (-d) d d |
87 | glVertex3f (-d) (-d) d | 87 | glVertex3f (-d) (-d) d |
88 | 88 | ||
89 | --Top | 89 | --Top |
90 | --glNormal3f 0 1 0 | 90 | --glNormal3f 0 1 0 |
91 | applyNormal $ normals !! 4 | 91 | applyNormal $ normals !! 4 |
92 | glVertex3f (-d) d (-d) | 92 | glVertex3f (-d) d (-d) |
93 | glVertex3f d d (-d) | 93 | glVertex3f d d (-d) |
94 | glVertex3f d d d | 94 | glVertex3f d d d |
95 | glVertex3f (-d) d d | 95 | glVertex3f (-d) d d |
96 | 96 | ||
97 | --Bottom | 97 | --Bottom |
98 | --glNormal3f 0 (-1) 0 | 98 | --glNormal3f 0 (-1) 0 |
99 | applyNormal $ normals !! 5 | 99 | applyNormal $ normals !! 5 |
100 | glVertex3f d (-d) d | 100 | glVertex3f d (-d) d |
101 | glVertex3f d (-d) (-d) | 101 | glVertex3f d (-d) (-d) |
102 | glVertex3f (-d) (-d) (-d) | 102 | glVertex3f (-d) (-d) (-d) |
103 | glVertex3f (-d) (-d) d | 103 | glVertex3f (-d) (-d) d |
104 | 104 | ||
105 | glEnd | 105 | glEnd |
106 | 106 | ||
107 | glPopMatrix | 107 | glPopMatrix |
108 | 108 | ||
109 | 109 | ||
110 | normals = [vec3 0 0 (-1), vec3 0 0 1, vec3 1 0 0, vec3 (-1) 0 0, vec3 0 1 0, vec3 0 (-1) 0] | 110 | normals = [vec3 0 0 (-1), vec3 0 0 1, vec3 1 0 0, vec3 (-1) 0 0, vec3 0 1 0, vec3 0 (-1) 0] |
111 | 111 | ||
112 | 112 | ||
113 | -- | Renders a box with normals facing outwards. | 113 | -- | Renders a box with normals facing outwards. |
114 | renderOutwards :: Center -- ^ The box's center. | 114 | renderOutwards :: Center -- ^ The box's center. |
115 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. | 115 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. |
116 | -> Colour -- ^ The box's colour. | 116 | -> Colour -- ^ The box's colour. |
117 | -> IO () | 117 | -> IO () |
118 | renderOutwards c l col = render c l col normals | 118 | renderOutwards c l col = render c l col normals |
119 | 119 | ||
120 | 120 | ||
121 | -- | Renders a box with normals facing inwards. | 121 | -- | Renders a box with normals facing inwards. |
122 | renderInwards :: Center -- ^ The box's center. | 122 | renderInwards :: Center -- ^ The box's center. |
123 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. | 123 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. |
124 | -> Colour -- ^ The box's colour. | 124 | -> Colour -- ^ The box's colour. |
125 | -> IO () | 125 | -> IO () |
126 | renderInwards c l col = do | 126 | renderInwards c l col = do |
127 | glFrontFace gl_CW | 127 | glFrontFace gl_CW |
128 | render c l col $ Prelude.map neg normals | 128 | render c l col $ Prelude.map neg normals |
129 | glFrontFace gl_CCW | 129 | glFrontFace gl_CCW |
130 | 130 | ||
131 | 131 | ||
132 | renderEdges :: Center -- ^ The box's center. | 132 | renderEdges :: Center -- ^ The box's center. |
133 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. | 133 | -> Length -- ^ The perpendicular distance from the box's center to any of its sides. |
134 | -> Colour -- ^ The box's colour. | 134 | -> Colour -- ^ The box's colour. |
135 | -> IO () | 135 | -> IO () |
136 | renderEdges c l col = do | 136 | renderEdges c l col = do |
137 | glPushMatrix | 137 | glPushMatrix |
138 | glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) | 138 | glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) |
139 | applyColour col | 139 | applyColour col |
140 | 140 | ||
141 | let d = unsafeCoerce l | 141 | let d = unsafeCoerce l |
142 | 142 | ||
143 | --Front | 143 | --Front |
144 | glBegin gl_LINE_STRIP | 144 | glBegin gl_LINE_STRIP |
145 | glVertex3f d (-d) (-d) | 145 | glVertex3f d (-d) (-d) |
146 | glVertex3f d d (-d) | 146 | glVertex3f d d (-d) |
147 | glVertex3f (-d) d (-d) | 147 | glVertex3f (-d) d (-d) |
148 | glVertex3f (-d) (-d) (-d) | 148 | glVertex3f (-d) (-d) (-d) |
149 | glEnd | 149 | glEnd |
150 | 150 | ||
151 | --Back | 151 | --Back |
152 | glBegin gl_LINE_STRIP | 152 | glBegin gl_LINE_STRIP |
153 | glVertex3f (-d) (-d) d | 153 | glVertex3f (-d) (-d) d |
154 | glVertex3f (-d) d d | 154 | glVertex3f (-d) d d |
155 | glVertex3f d d d | 155 | glVertex3f d d d |
156 | glVertex3f d (-d) d | 156 | glVertex3f d (-d) d |
157 | glVertex3f (-d) (-d) d | 157 | glVertex3f (-d) (-d) d |
158 | glEnd | 158 | glEnd |
159 | 159 | ||
160 | --Right | 160 | --Right |
161 | glBegin gl_LINE_STRIP | 161 | glBegin gl_LINE_STRIP |
162 | glVertex3f d (-d) (-d) | 162 | glVertex3f d (-d) (-d) |
163 | glVertex3f d (-d) d | 163 | glVertex3f d (-d) d |
164 | glVertex3f d d d | 164 | glVertex3f d d d |
165 | glVertex3f d d (-d) | 165 | glVertex3f d d (-d) |
166 | glEnd | 166 | glEnd |
167 | 167 | ||
168 | --Left | 168 | --Left |
169 | glBegin gl_LINE_STRIP | 169 | glBegin gl_LINE_STRIP |
170 | glVertex3f (-d) (-d) (-d) | 170 | glVertex3f (-d) (-d) (-d) |
171 | glVertex3f (-d) d (-d) | 171 | glVertex3f (-d) d (-d) |
172 | glVertex3f (-d) d d | 172 | glVertex3f (-d) d d |
173 | glVertex3f (-d) (-d) d | 173 | glVertex3f (-d) (-d) d |
174 | glEnd | 174 | glEnd |
175 | 175 | ||
176 | --Top | 176 | --Top |
177 | glBegin gl_LINE_STRIP | 177 | glBegin gl_LINE_STRIP |
178 | glVertex3f (-d) d (-d) | 178 | glVertex3f (-d) d (-d) |
179 | glVertex3f d d (-d) | 179 | glVertex3f d d (-d) |
180 | glVertex3f d d d | 180 | glVertex3f d d d |
181 | glVertex3f (-d) d d | 181 | glVertex3f (-d) d d |
182 | glEnd | 182 | glEnd |
183 | 183 | ||
184 | --Bottom | 184 | --Bottom |
185 | glBegin gl_LINE_STRIP | 185 | glBegin gl_LINE_STRIP |
186 | glVertex3f d (-d) d | 186 | glVertex3f d (-d) d |
187 | glVertex3f d (-d) (-d) | 187 | glVertex3f d (-d) (-d) |
188 | glVertex3f (-d) (-d) (-d) | 188 | glVertex3f (-d) (-d) (-d) |
189 | glVertex3f (-d) (-d) d | 189 | glVertex3f (-d) (-d) d |
190 | glEnd | 190 | glEnd |
191 | 191 | ||
192 | glPopMatrix | 192 | glPopMatrix |
193 | \ No newline at end of file | 193 | \ No newline at end of file |
diff --git a/Spear/Render/Material.hs b/Spear/Render/Material.hs index 83d8742..d9c60ea 100644 --- a/Spear/Render/Material.hs +++ b/Spear/Render/Material.hs | |||
@@ -1,16 +1,16 @@ | |||
1 | module Spear.Render.Material | 1 | module Spear.Render.Material |
2 | ( Material(..) | 2 | ( Material(..) |
3 | ) | 3 | ) |
4 | where | 4 | where |
5 | 5 | ||
6 | 6 | ||
7 | import Spear.Math.Vector | 7 | import Spear.Math.Vector |
8 | 8 | ||
9 | 9 | ||
10 | data Material = Material | 10 | data Material = Material |
11 | { ke :: Vector4 | 11 | { ke :: Vector4 |
12 | , ka :: Vector4 | 12 | , ka :: Vector4 |
13 | , kd :: Vector4 | 13 | , kd :: Vector4 |
14 | , ks :: Vector4 | 14 | , ks :: Vector4 |
15 | , shininess :: Float | 15 | , shininess :: Float |
16 | } | 16 | } |
diff --git a/Spear/Render/Model.hsc b/Spear/Render/Model.hsc index d7dbdfe..ba6bf39 100644 --- a/Spear/Render/Model.hsc +++ b/Spear/Render/Model.hsc | |||
@@ -1,54 +1,54 @@ | |||
1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} | 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} |
2 | 2 | ||
3 | module Spear.Render.Model | 3 | module Spear.Render.Model |
4 | ( | 4 | ( |
5 | RenderModel(..) | 5 | RenderModel(..) |
6 | , renderModelFromModel | 6 | , renderModelFromModel |
7 | ) | 7 | ) |
8 | where | 8 | where |
9 | 9 | ||
10 | import qualified Spear.Assets.Model as Assets | 10 | import qualified Spear.Assets.Model as Assets |
11 | import Spear.Game | 11 | import Spear.Game |
12 | 12 | ||
13 | import Foreign.Ptr | 13 | import Foreign.Ptr |
14 | import Foreign.C.Types | 14 | import Foreign.C.Types |
15 | import Foreign.Marshal.Alloc | 15 | import Foreign.Marshal.Alloc |
16 | import Foreign.Marshal.Array | 16 | import Foreign.Marshal.Array |
17 | import Foreign.Marshal.Utils (with) | 17 | import Foreign.Marshal.Utils (with) |
18 | import Foreign.Storable | 18 | import Foreign.Storable |
19 | 19 | ||
20 | #include "RenderModel.h" | 20 | #include "RenderModel.h" |
21 | 21 | ||
22 | data Vec3 = Vec3 !CFloat !CFloat !CFloat | 22 | data Vec3 = Vec3 !CFloat !CFloat !CFloat |
23 | 23 | ||
24 | data TexCoord = TexCoord !CFloat !CFloat | 24 | data TexCoord = TexCoord !CFloat !CFloat |
25 | 25 | ||
26 | data RenderModel = RenderModel | 26 | data RenderModel = RenderModel |
27 | { elements :: Ptr CChar | 27 | { elements :: Ptr CChar |
28 | , numFrames :: CUInt | 28 | , numFrames :: CUInt |
29 | , numVertices :: CUInt -- ^ Number of vertices per frame. | 29 | , numVertices :: CUInt -- ^ Number of vertices per frame. |
30 | } | 30 | } |
31 | 31 | ||
32 | instance Storable RenderModel where | 32 | instance Storable RenderModel where |
33 | sizeOf _ = #{size RenderModel} | 33 | sizeOf _ = #{size RenderModel} |
34 | alignment _ = alignment (undefined :: CUInt) | 34 | alignment _ = alignment (undefined :: CUInt) |
35 | 35 | ||
36 | peek ptr = do | 36 | peek ptr = do |
37 | elements <- #{peek RenderModel, elements} ptr | 37 | elements <- #{peek RenderModel, elements} ptr |
38 | numFrames <- #{peek RenderModel, numFrames} ptr | 38 | numFrames <- #{peek RenderModel, numFrames} ptr |
39 | numVertices <- #{peek RenderModel, numVertices} ptr | 39 | numVertices <- #{peek RenderModel, numVertices} ptr |
40 | return $ RenderModel elements numFrames numVertices | 40 | return $ RenderModel elements numFrames numVertices |
41 | 41 | ||
42 | poke ptr (RenderModel elements numFrames numVertices) = do | 42 | poke ptr (RenderModel elements numFrames numVertices) = do |
43 | #{poke RenderModel, elements} ptr elements | 43 | #{poke RenderModel, elements} ptr elements |
44 | #{poke RenderModel, numFrames} ptr numFrames | 44 | #{poke RenderModel, numFrames} ptr numFrames |
45 | #{poke RenderModel, numVertices} ptr numVertices | 45 | #{poke RenderModel, numVertices} ptr numVertices |
46 | 46 | ||
47 | foreign import ccall "RenderModel.h render_model_from_model_asset" | 47 | foreign import ccall "RenderModel.h render_model_from_model_asset" |
48 | render_model_from_model_asset :: Ptr Assets.Model -> Ptr RenderModel -> IO Int | 48 | render_model_from_model_asset :: Ptr Assets.Model -> Ptr RenderModel -> IO Int |
49 | 49 | ||
50 | -- | Convert the given 'Model' to a 'ModelData' instance. | 50 | -- | Convert the given 'Model' to a 'ModelData' instance. |
51 | renderModelFromModel :: Assets.Model -> IO RenderModel | 51 | renderModelFromModel :: Assets.Model -> IO RenderModel |
52 | renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do | 52 | renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do |
53 | render_model_from_model_asset mPtr mdPtr | 53 | render_model_from_model_asset mPtr mdPtr |
54 | peek mdPtr | 54 | peek mdPtr |
diff --git a/Spear/Render/Program.hs b/Spear/Render/Program.hs index 8f3fba7..b5a8658 100644 --- a/Spear/Render/Program.hs +++ b/Spear/Render/Program.hs | |||
@@ -1,102 +1,102 @@ | |||
1 | module Spear.Render.Program | 1 | module Spear.Render.Program |
2 | ( | 2 | ( |
3 | StaticProgram(..) | 3 | StaticProgram(..) |
4 | , AnimatedProgram(..) | 4 | , AnimatedProgram(..) |
5 | , Program(..) | 5 | , Program(..) |
6 | , ProgramUniforms(..) | 6 | , ProgramUniforms(..) |
7 | , StaticProgramChannels(..) | 7 | , StaticProgramChannels(..) |
8 | , StaticProgramUniforms(..) | 8 | , StaticProgramUniforms(..) |
9 | , AnimatedProgramChannels(..) | 9 | , AnimatedProgramChannels(..) |
10 | , AnimatedProgramUniforms(..) | 10 | , AnimatedProgramUniforms(..) |
11 | ) | 11 | ) |
12 | where | 12 | where |
13 | 13 | ||
14 | import Spear.GL | 14 | import Spear.GL |
15 | 15 | ||
16 | data StaticProgram = StaticProgram | 16 | data StaticProgram = StaticProgram |
17 | { staticProgram :: GLSLProgram | 17 | { staticProgram :: GLSLProgram |
18 | , staticProgramChannels :: StaticProgramChannels | 18 | , staticProgramChannels :: StaticProgramChannels |
19 | , staticProgramUniforms :: StaticProgramUniforms | 19 | , staticProgramUniforms :: StaticProgramUniforms |
20 | } | 20 | } |
21 | 21 | ||
22 | data AnimatedProgram = AnimatedProgram | 22 | data AnimatedProgram = AnimatedProgram |
23 | { animatedProgram :: GLSLProgram | 23 | { animatedProgram :: GLSLProgram |
24 | , animatedProgramChannels :: AnimatedProgramChannels | 24 | , animatedProgramChannels :: AnimatedProgramChannels |
25 | , animatedProgramUniforms :: AnimatedProgramUniforms | 25 | , animatedProgramUniforms :: AnimatedProgramUniforms |
26 | } | 26 | } |
27 | 27 | ||
28 | data StaticProgramChannels = StaticProgramChannels | 28 | data StaticProgramChannels = StaticProgramChannels |
29 | { vertexChannel :: GLuint -- ^ Vertex channel. | 29 | { vertexChannel :: GLuint -- ^ Vertex channel. |
30 | , normalChannel :: GLuint -- ^ Normal channel. | 30 | , normalChannel :: GLuint -- ^ Normal channel. |
31 | , stexChannel :: GLuint -- ^ Texture channel. | 31 | , stexChannel :: GLuint -- ^ Texture channel. |
32 | } | 32 | } |
33 | 33 | ||
34 | data AnimatedProgramChannels = AnimatedProgramChannels | 34 | data AnimatedProgramChannels = AnimatedProgramChannels |
35 | { vertexChannel1 :: GLuint -- ^ Vertex channel 1. | 35 | { vertexChannel1 :: GLuint -- ^ Vertex channel 1. |
36 | , vertexChannel2 :: GLuint -- ^ Vertex channel 2. | 36 | , vertexChannel2 :: GLuint -- ^ Vertex channel 2. |
37 | , normalChannel1 :: GLuint -- ^ Normal channel 1. | 37 | , normalChannel1 :: GLuint -- ^ Normal channel 1. |
38 | , normalChannel2 :: GLuint -- ^ Normal channel 2. | 38 | , normalChannel2 :: GLuint -- ^ Normal channel 2. |
39 | , atexChannel :: GLuint -- ^ Texture channel. | 39 | , atexChannel :: GLuint -- ^ Texture channel. |
40 | } | 40 | } |
41 | 41 | ||
42 | data StaticProgramUniforms = StaticProgramUniforms | 42 | data StaticProgramUniforms = StaticProgramUniforms |
43 | { skaLoc :: GLint -- ^ Material ambient uniform location. | 43 | { skaLoc :: GLint -- ^ Material ambient uniform location. |
44 | , skdLoc :: GLint -- ^ Material diffuse uniform location. | 44 | , skdLoc :: GLint -- ^ Material diffuse uniform location. |
45 | , sksLoc :: GLint -- ^ Material specular uniform location. | 45 | , sksLoc :: GLint -- ^ Material specular uniform location. |
46 | , sshiLoc :: GLint -- ^ Material shininess uniform location. | 46 | , sshiLoc :: GLint -- ^ Material shininess uniform location. |
47 | , stexLoc :: GLint -- ^ Texture sampler location. | 47 | , stexLoc :: GLint -- ^ Texture sampler location. |
48 | , smodelviewLoc :: GLint -- ^ Modelview matrix location. | 48 | , smodelviewLoc :: GLint -- ^ Modelview matrix location. |
49 | , snormalmatLoc :: GLint -- ^ Normal matrix location. | 49 | , snormalmatLoc :: GLint -- ^ Normal matrix location. |
50 | , sprojLoc :: GLint -- ^ Projection matrix location. | 50 | , sprojLoc :: GLint -- ^ Projection matrix location. |
51 | } | 51 | } |
52 | 52 | ||
53 | data AnimatedProgramUniforms = AnimatedProgramUniforms | 53 | data AnimatedProgramUniforms = AnimatedProgramUniforms |
54 | { akaLoc :: GLint -- ^ Material ambient uniform location. | 54 | { akaLoc :: GLint -- ^ Material ambient uniform location. |
55 | , akdLoc :: GLint -- ^ Material diffuse uniform location. | 55 | , akdLoc :: GLint -- ^ Material diffuse uniform location. |
56 | , aksLoc :: GLint -- ^ Material specular uniform location. | 56 | , aksLoc :: GLint -- ^ Material specular uniform location. |
57 | , ashiLoc :: GLint -- ^ Material shininess uniform location. | 57 | , ashiLoc :: GLint -- ^ Material shininess uniform location. |
58 | , atexLoc :: GLint -- ^ Texture sampler location. | 58 | , atexLoc :: GLint -- ^ Texture sampler location. |
59 | , fpLoc :: GLint -- ^ Frame progress uniform location. | 59 | , fpLoc :: GLint -- ^ Frame progress uniform location. |
60 | , amodelviewLoc :: GLint -- ^ Modelview matrix location. | 60 | , amodelviewLoc :: GLint -- ^ Modelview matrix location. |
61 | , anormalmatLoc :: GLint -- ^ Normal matrix location. | 61 | , anormalmatLoc :: GLint -- ^ Normal matrix location. |
62 | , aprojLoc :: GLint -- ^ Projection matrix location. | 62 | , aprojLoc :: GLint -- ^ Projection matrix location. |
63 | } | 63 | } |
64 | 64 | ||
65 | class Program a where | 65 | class Program a where |
66 | program :: a -> GLSLProgram | 66 | program :: a -> GLSLProgram |
67 | 67 | ||
68 | instance Program StaticProgram where | 68 | instance Program StaticProgram where |
69 | program = staticProgram | 69 | program = staticProgram |
70 | 70 | ||
71 | instance Program AnimatedProgram where | 71 | instance Program AnimatedProgram where |
72 | program = animatedProgram | 72 | program = animatedProgram |
73 | 73 | ||
74 | class ProgramUniforms a where | 74 | class ProgramUniforms a where |
75 | kaLoc :: a -> GLint | 75 | kaLoc :: a -> GLint |
76 | kdLoc :: a -> GLint | 76 | kdLoc :: a -> GLint |
77 | ksLoc :: a -> GLint | 77 | ksLoc :: a -> GLint |
78 | shiLoc :: a -> GLint | 78 | shiLoc :: a -> GLint |
79 | texLoc :: a -> GLint | 79 | texLoc :: a -> GLint |
80 | modelviewLoc :: a -> GLint | 80 | modelviewLoc :: a -> GLint |
81 | normalmatLoc :: a -> GLint | 81 | normalmatLoc :: a -> GLint |
82 | projLoc :: a -> GLint | 82 | projLoc :: a -> GLint |
83 | 83 | ||
84 | instance ProgramUniforms StaticProgramUniforms where | 84 | instance ProgramUniforms StaticProgramUniforms where |
85 | kaLoc = skaLoc | 85 | kaLoc = skaLoc |
86 | kdLoc = skdLoc | 86 | kdLoc = skdLoc |
87 | ksLoc = sksLoc | 87 | ksLoc = sksLoc |
88 | shiLoc = sshiLoc | 88 | shiLoc = sshiLoc |
89 | texLoc = stexLoc | 89 | texLoc = stexLoc |
90 | modelviewLoc = smodelviewLoc | 90 | modelviewLoc = smodelviewLoc |
91 | normalmatLoc = snormalmatLoc | 91 | normalmatLoc = snormalmatLoc |
92 | projLoc = sprojLoc | 92 | projLoc = sprojLoc |
93 | 93 | ||
94 | instance ProgramUniforms AnimatedProgramUniforms where | 94 | instance ProgramUniforms AnimatedProgramUniforms where |
95 | kaLoc = akaLoc | 95 | kaLoc = akaLoc |
96 | kdLoc = akdLoc | 96 | kdLoc = akdLoc |
97 | ksLoc = aksLoc | 97 | ksLoc = aksLoc |
98 | shiLoc = ashiLoc | 98 | shiLoc = ashiLoc |
99 | texLoc = atexLoc | 99 | texLoc = atexLoc |
100 | modelviewLoc = amodelviewLoc | 100 | modelviewLoc = amodelviewLoc |
101 | normalmatLoc = anormalmatLoc | 101 | normalmatLoc = anormalmatLoc |
102 | projLoc = aprojLoc | 102 | projLoc = aprojLoc |
diff --git a/Spear/Render/RenderModel.c b/Spear/Render/RenderModel.c index 3d18a4b..1543052 100644 --- a/Spear/Render/RenderModel.c +++ b/Spear/Render/RenderModel.c | |||
@@ -1,232 +1,232 @@ | |||
1 | #include "RenderModel.h" | 1 | #include "RenderModel.h" |
2 | #include <stdlib.h> // free | 2 | #include <stdlib.h> // free |
3 | #include <string.h> // memcpy | 3 | #include <string.h> // memcpy |
4 | #include <stdio.h> | 4 | #include <stdio.h> |
5 | 5 | ||
6 | 6 | ||
7 | static void safe_free (void* ptr) | 7 | static void safe_free (void* ptr) |
8 | { | 8 | { |
9 | if (ptr) | 9 | if (ptr) |
10 | { | 10 | { |
11 | free (ptr); | 11 | free (ptr); |
12 | ptr = 0; | 12 | ptr = 0; |
13 | } | 13 | } |
14 | } | 14 | } |
15 | 15 | ||
16 | 16 | ||
17 | /// Populate elements of an animated model to be rendered from | 17 | /// Populate elements of an animated model to be rendered from |
18 | /// start to end in a loop. | 18 | /// start to end in a loop. |
19 | /*int populate_elements_animated (Model* model_asset, RenderModel* model) | 19 | /*int populate_elements_animated (Model* model_asset, RenderModel* model) |
20 | { | 20 | { |
21 | size_t nverts = model_asset->numVertices; | 21 | size_t nverts = model_asset->numVertices; |
22 | size_t ntriangles = model_asset->numTriangles; | 22 | size_t ntriangles = model_asset->numTriangles; |
23 | size_t nframes = model_asset->numFrames; | 23 | size_t nframes = model_asset->numFrames; |
24 | size_t n = nframes * ntriangles * 3; | 24 | size_t n = nframes * ntriangles * 3; |
25 | 25 | ||
26 | model->elements = malloc (56 * n); | 26 | model->elements = malloc (56 * n); |
27 | if (!model->elements) return -1; | 27 | if (!model->elements) return -1; |
28 | 28 | ||
29 | // Populate elements. | 29 | // Populate elements. |
30 | 30 | ||
31 | size_t f, i; | 31 | size_t f, i; |
32 | 32 | ||
33 | char* elem = (char*) model->elements; | 33 | char* elem = (char*) model->elements; |
34 | vec3* v1 = model_asset->vertices; | 34 | vec3* v1 = model_asset->vertices; |
35 | vec3* v2 = v1 + nverts; | 35 | vec3* v2 = v1 + nverts; |
36 | vec3* n1 = model_asset->normals; | 36 | vec3* n1 = model_asset->normals; |
37 | vec3* n2 = n1 + nverts; | 37 | vec3* n2 = n1 + nverts; |
38 | texCoord* tex = model_asset->texCoords; | 38 | texCoord* tex = model_asset->texCoords; |
39 | 39 | ||
40 | for (f = 0; f < nframes; ++f) | 40 | for (f = 0; f < nframes; ++f) |
41 | { | 41 | { |
42 | triangle* t = model_asset->triangles; | 42 | triangle* t = model_asset->triangles; |
43 | 43 | ||
44 | for (i = 0; i < ntriangles; ++i) | 44 | for (i = 0; i < ntriangles; ++i) |
45 | { | 45 | { |
46 | *((vec3*) elem) = v1[t->vertexIndices[0]]; | 46 | *((vec3*) elem) = v1[t->vertexIndices[0]]; |
47 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; | 47 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; |
48 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; | 48 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; |
49 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; | 49 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; |
50 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; | 50 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; |
51 | elem += 56; | 51 | elem += 56; |
52 | 52 | ||
53 | *((vec3*) elem) = v1[t->vertexIndices[1]]; | 53 | *((vec3*) elem) = v1[t->vertexIndices[1]]; |
54 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; | 54 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; |
55 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; | 55 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; |
56 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; | 56 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; |
57 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; | 57 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; |
58 | elem += 56; | 58 | elem += 56; |
59 | 59 | ||
60 | *((vec3*) elem) = v1[t->vertexIndices[2]]; | 60 | *((vec3*) elem) = v1[t->vertexIndices[2]]; |
61 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; | 61 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; |
62 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; | 62 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; |
63 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; | 63 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; |
64 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; | 64 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; |
65 | elem += 56; | 65 | elem += 56; |
66 | 66 | ||
67 | t++; | 67 | t++; |
68 | } | 68 | } |
69 | 69 | ||
70 | v1 += nverts; | 70 | v1 += nverts; |
71 | v2 += nverts; | 71 | v2 += nverts; |
72 | n1 += nverts; | 72 | n1 += nverts; |
73 | n2 += nverts; | 73 | n2 += nverts; |
74 | 74 | ||
75 | if (f == nframes-2) | 75 | if (f == nframes-2) |
76 | { | 76 | { |
77 | v2 = model_asset->vertices; | 77 | v2 = model_asset->vertices; |
78 | n2 = model_asset->normals; | 78 | n2 = model_asset->normals; |
79 | } | 79 | } |
80 | } | 80 | } |
81 | 81 | ||
82 | return 0; | 82 | return 0; |
83 | }*/ | 83 | }*/ |
84 | 84 | ||
85 | 85 | ||
86 | /// Populate elements of an animated model according to its frames | 86 | /// Populate elements of an animated model according to its frames |
87 | /// of animation. | 87 | /// of animation. |
88 | int populate_elements_animated (Model* model_asset, RenderModel* model) | 88 | int populate_elements_animated (Model* model_asset, RenderModel* model) |
89 | { | 89 | { |
90 | size_t nverts = model_asset->numVertices; | 90 | size_t nverts = model_asset->numVertices; |
91 | size_t ntriangles = model_asset->numTriangles; | 91 | size_t ntriangles = model_asset->numTriangles; |
92 | size_t nframes = model_asset->numFrames; | 92 | size_t nframes = model_asset->numFrames; |
93 | size_t n = nframes * ntriangles * 3; | 93 | size_t n = nframes * ntriangles * 3; |
94 | 94 | ||
95 | model->elements = malloc (56 * n); | 95 | model->elements = malloc (56 * n); |
96 | if (!model->elements) return -1; | 96 | if (!model->elements) return -1; |
97 | 97 | ||
98 | // Populate elements. | 98 | // Populate elements. |
99 | 99 | ||
100 | unsigned f, i, j, u; | 100 | unsigned f, i, j, u; |
101 | 101 | ||
102 | char* elem = (char*) model->elements; | 102 | char* elem = (char*) model->elements; |
103 | animation* anim = model_asset->animations; | 103 | animation* anim = model_asset->animations; |
104 | 104 | ||
105 | for (i = 0; i < model_asset->numAnimations; ++i, anim++) | 105 | for (i = 0; i < model_asset->numAnimations; ++i, anim++) |
106 | { | 106 | { |
107 | unsigned start = anim->start; | 107 | unsigned start = anim->start; |
108 | unsigned end = anim->end; | 108 | unsigned end = anim->end; |
109 | 109 | ||
110 | char singleFrameAnim = start == end; | 110 | char singleFrameAnim = start == end; |
111 | 111 | ||
112 | vec3* v1 = model_asset->vertices + start*nverts; | 112 | vec3* v1 = model_asset->vertices + start*nverts; |
113 | vec3* v2 = singleFrameAnim ? v1 : v1 + nverts; | 113 | vec3* v2 = singleFrameAnim ? v1 : v1 + nverts; |
114 | vec3* n1 = model_asset->normals + start*nverts; | 114 | vec3* n1 = model_asset->normals + start*nverts; |
115 | vec3* n2 = singleFrameAnim ? n1 : n1 + nverts; | 115 | vec3* n2 = singleFrameAnim ? n1 : n1 + nverts; |
116 | texCoord* tex = model_asset->texCoords; | 116 | texCoord* tex = model_asset->texCoords; |
117 | 117 | ||
118 | for (u = start; u <= end; ++u) | 118 | for (u = start; u <= end; ++u) |
119 | { | 119 | { |
120 | triangle* t = model_asset->triangles; | 120 | triangle* t = model_asset->triangles; |
121 | 121 | ||
122 | for (j = 0; j < ntriangles; ++j, t++) | 122 | for (j = 0; j < ntriangles; ++j, t++) |
123 | { | 123 | { |
124 | *((vec3*) elem) = v1[t->vertexIndices[0]]; | 124 | *((vec3*) elem) = v1[t->vertexIndices[0]]; |
125 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; | 125 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; |
126 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; | 126 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; |
127 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; | 127 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; |
128 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; | 128 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; |
129 | elem += 56; | 129 | elem += 56; |
130 | 130 | ||
131 | *((vec3*) elem) = v1[t->vertexIndices[1]]; | 131 | *((vec3*) elem) = v1[t->vertexIndices[1]]; |
132 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; | 132 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; |
133 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; | 133 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; |
134 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; | 134 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; |
135 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; | 135 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; |
136 | elem += 56; | 136 | elem += 56; |
137 | 137 | ||
138 | *((vec3*) elem) = v1[t->vertexIndices[2]]; | 138 | *((vec3*) elem) = v1[t->vertexIndices[2]]; |
139 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; | 139 | *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; |
140 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; | 140 | *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; |
141 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; | 141 | *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; |
142 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; | 142 | *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; |
143 | elem += 56; | 143 | elem += 56; |
144 | } | 144 | } |
145 | 145 | ||
146 | // Advance to the next frame of animation of the current | 146 | // Advance to the next frame of animation of the current |
147 | // animation. | 147 | // animation. |
148 | v1 += nverts; | 148 | v1 += nverts; |
149 | v2 += nverts; | 149 | v2 += nverts; |
150 | n1 += nverts; | 150 | n1 += nverts; |
151 | n2 += nverts; | 151 | n2 += nverts; |
152 | 152 | ||
153 | // Reset the secondary pointers to the beginning of the | 153 | // Reset the secondary pointers to the beginning of the |
154 | // animation when we are about to reach the last frame. | 154 | // animation when we are about to reach the last frame. |
155 | if (u == end-1) | 155 | if (u == end-1) |
156 | { | 156 | { |
157 | v2 = model_asset->vertices + start*nverts; | 157 | v2 = model_asset->vertices + start*nverts; |
158 | n2 = model_asset->normals + start*nverts; | 158 | n2 = model_asset->normals + start*nverts; |
159 | } | 159 | } |
160 | } | 160 | } |
161 | } | 161 | } |
162 | 162 | ||
163 | return 0; | 163 | return 0; |
164 | } | 164 | } |
165 | 165 | ||
166 | 166 | ||
167 | int populate_elements_static (Model* model_asset, RenderModel* model) | 167 | int populate_elements_static (Model* model_asset, RenderModel* model) |
168 | { | 168 | { |
169 | size_t nverts = model_asset->numVertices; | 169 | size_t nverts = model_asset->numVertices; |
170 | size_t ntriangles = model_asset->numTriangles; | 170 | size_t ntriangles = model_asset->numTriangles; |
171 | size_t n = ntriangles * 3; | 171 | size_t n = ntriangles * 3; |
172 | 172 | ||
173 | model->elements = malloc (32 * n); | 173 | model->elements = malloc (32 * n); |
174 | if (!model->elements) return -1; | 174 | if (!model->elements) return -1; |
175 | 175 | ||
176 | // Populate elements. | 176 | // Populate elements. |
177 | 177 | ||
178 | size_t f, i; | 178 | size_t f, i; |
179 | 179 | ||
180 | char* elem = (char*) model->elements; | 180 | char* elem = (char*) model->elements; |
181 | vec3* vert = model_asset->vertices; | 181 | vec3* vert = model_asset->vertices; |
182 | vec3* norm = model_asset->normals; | 182 | vec3* norm = model_asset->normals; |
183 | texCoord* tex = model_asset->texCoords; | 183 | texCoord* tex = model_asset->texCoords; |
184 | 184 | ||
185 | triangle* t = model_asset->triangles; | 185 | triangle* t = model_asset->triangles; |
186 | 186 | ||
187 | for (i = 0; i < ntriangles; ++i) | 187 | for (i = 0; i < ntriangles; ++i) |
188 | { | 188 | { |
189 | *((vec3*) elem) = vert[t->vertexIndices[0]]; | 189 | *((vec3*) elem) = vert[t->vertexIndices[0]]; |
190 | *((vec3*) (elem + 12)) = norm[t->vertexIndices[0]]; | 190 | *((vec3*) (elem + 12)) = norm[t->vertexIndices[0]]; |
191 | *((texCoord*) (elem + 24)) = tex[t->textureIndices[0]]; | 191 | *((texCoord*) (elem + 24)) = tex[t->textureIndices[0]]; |
192 | elem += 32; | 192 | elem += 32; |
193 | 193 | ||
194 | *((vec3*) elem) = vert[t->vertexIndices[1]]; | 194 | *((vec3*) elem) = vert[t->vertexIndices[1]]; |
195 | *((vec3*) (elem + 12)) = norm[t->vertexIndices[1]]; | 195 | *((vec3*) (elem + 12)) = norm[t->vertexIndices[1]]; |
196 | *((texCoord*) (elem + 24)) = tex[t->textureIndices[1]]; | 196 | *((texCoord*) (elem + 24)) = tex[t->textureIndices[1]]; |
197 | elem += 32; | 197 | elem += 32; |
198 | 198 | ||
199 | *((vec3*) elem) = vert[t->vertexIndices[2]]; | 199 | *((vec3*) elem) = vert[t->vertexIndices[2]]; |
200 | *((vec3*) (elem + 12)) = norm[t->vertexIndices[2]]; | 200 | *((vec3*) (elem + 12)) = norm[t->vertexIndices[2]]; |
201 | *((texCoord*) (elem + 24)) = tex[t->textureIndices[2]]; | 201 | *((texCoord*) (elem + 24)) = tex[t->textureIndices[2]]; |
202 | elem += 32; | 202 | elem += 32; |
203 | 203 | ||
204 | t++; | 204 | t++; |
205 | } | 205 | } |
206 | 206 | ||
207 | return 0; | 207 | return 0; |
208 | } | 208 | } |
209 | 209 | ||
210 | 210 | ||
211 | int render_model_from_model_asset (Model* model_asset, RenderModel* model) | 211 | int render_model_from_model_asset (Model* model_asset, RenderModel* model) |
212 | { | 212 | { |
213 | U32 ntriangles = model_asset->numTriangles; | 213 | U32 ntriangles = model_asset->numTriangles; |
214 | U32 nframes = model_asset->numFrames; | 214 | U32 nframes = model_asset->numFrames; |
215 | 215 | ||
216 | int result; | 216 | int result; |
217 | if (nframes > 1) result = populate_elements_animated (model_asset, model); | 217 | if (nframes > 1) result = populate_elements_animated (model_asset, model); |
218 | else result = populate_elements_static (model_asset, model); | 218 | else result = populate_elements_static (model_asset, model); |
219 | 219 | ||
220 | if (result != 0) return result; | 220 | if (result != 0) return result; |
221 | 221 | ||
222 | model->numFrames = nframes; | 222 | model->numFrames = nframes; |
223 | model->numVertices = ntriangles * 3; // Number of vertices per frame. | 223 | model->numVertices = ntriangles * 3; // Number of vertices per frame. |
224 | 224 | ||
225 | return 0; | 225 | return 0; |
226 | } | 226 | } |
227 | 227 | ||
228 | 228 | ||
229 | void render_model_free (RenderModel* model) | 229 | void render_model_free (RenderModel* model) |
230 | { | 230 | { |
231 | safe_free (model->elements); | 231 | safe_free (model->elements); |
232 | } | 232 | } |
diff --git a/Spear/Render/RenderModel.h b/Spear/Render/RenderModel.h index cb70a19..6a5fb5e 100644 --- a/Spear/Render/RenderModel.h +++ b/Spear/Render/RenderModel.h | |||
@@ -1,49 +1,49 @@ | |||
1 | #ifndef _SPEAR_RENDER_MODEL_H | 1 | #ifndef _SPEAR_RENDER_MODEL_H |
2 | #define _SPEAR_RENDER_MODEL_H | 2 | #define _SPEAR_RENDER_MODEL_H |
3 | 3 | ||
4 | #include "Model.h" | 4 | #include "Model.h" |
5 | 5 | ||
6 | 6 | ||
7 | /// Represents a renderable model. | 7 | /// Represents a renderable model. |
8 | /** | 8 | /** |
9 | * If the model is animated: | 9 | * If the model is animated: |
10 | * | 10 | * |
11 | * Buffer layout: | 11 | * Buffer layout: |
12 | * vert1 vert2 norm1 norm2 texc | 12 | * vert1 vert2 norm1 norm2 texc |
13 | * | 13 | * |
14 | * element size = (3 + 3 + 3 + 3 + 2)*4 = 56 B | 14 | * element size = (3 + 3 + 3 + 3 + 2)*4 = 56 B |
15 | * buffer size = element size * num vertices = 56n | 15 | * buffer size = element size * num vertices = 56n |
16 | * | 16 | * |
17 | * If the model is static: | 17 | * If the model is static: |
18 | * | 18 | * |
19 | * Buffer layout: | 19 | * Buffer layout: |
20 | * vert norm texc | 20 | * vert norm texc |
21 | * | 21 | * |
22 | * element size = (3 + 3 + 2)*4 = 32 B | 22 | * element size = (3 + 3 + 2)*4 = 32 B |
23 | * buffer size = element size * num vertices = 32n | 23 | * buffer size = element size * num vertices = 32n |
24 | * | 24 | * |
25 | **/ | 25 | **/ |
26 | typedef struct | 26 | typedef struct |
27 | { | 27 | { |
28 | void* elements; | 28 | void* elements; |
29 | U32 numFrames; | 29 | U32 numFrames; |
30 | U32 numVertices; // Number of vertices per frame. | 30 | U32 numVertices; // Number of vertices per frame. |
31 | } | 31 | } |
32 | RenderModel; | 32 | RenderModel; |
33 | 33 | ||
34 | 34 | ||
35 | #ifdef __cplusplus | 35 | #ifdef __cplusplus |
36 | extern "C" { | 36 | extern "C" { |
37 | #endif | 37 | #endif |
38 | 38 | ||
39 | int render_model_from_model_asset (Model* model_asset, RenderModel* render_model); | 39 | int render_model_from_model_asset (Model* model_asset, RenderModel* render_model); |
40 | 40 | ||
41 | void render_model_free (RenderModel* model); | 41 | void render_model_free (RenderModel* model); |
42 | 42 | ||
43 | #ifdef __cplusplus | 43 | #ifdef __cplusplus |
44 | } | 44 | } |
45 | #endif | 45 | #endif |
46 | 46 | ||
47 | 47 | ||
48 | #endif // _SPEAR_RENDER_MODEL_H | 48 | #endif // _SPEAR_RENDER_MODEL_H |
49 | 49 | ||
diff --git a/Spear/Render/Sphere.hs b/Spear/Render/Sphere.hs index 25d775a..4e74375 100644 --- a/Spear/Render/Sphere.hs +++ b/Spear/Render/Sphere.hs | |||
@@ -1,45 +1,45 @@ | |||
1 | module Spear.Render.Sphere | 1 | module Spear.Render.Sphere |
2 | ( | 2 | ( |
3 | render | 3 | render |
4 | ) | 4 | ) |
5 | where | 5 | where |
6 | 6 | ||
7 | 7 | ||
8 | import Spear.Math.Vector as Vector | 8 | import Spear.Math.Vector as Vector |
9 | import Spear.Math.Matrix | 9 | import Spear.Math.Matrix |
10 | import Graphics.Rendering.OpenGL.Raw | 10 | import Graphics.Rendering.OpenGL.Raw |
11 | import Graphics.Rendering.OpenGL.GL.Colors | 11 | import Graphics.Rendering.OpenGL.GL.Colors |
12 | import qualified Graphics.Rendering.OpenGL.GLU as GLU | 12 | import qualified Graphics.Rendering.OpenGL.GLU as GLU |
13 | import Unsafe.Coerce | 13 | import Unsafe.Coerce |
14 | 14 | ||
15 | 15 | ||
16 | type Center = Vector R | 16 | type Center = Vector R |
17 | type Radius = R | 17 | type Radius = R |
18 | type Colour = Vector R | 18 | type Colour = Vector R |
19 | 19 | ||
20 | 20 | ||
21 | applyColour :: Colour -> IO () | 21 | applyColour :: Colour -> IO () |
22 | applyColour col = | 22 | applyColour col = |
23 | if Vector.length col == 4 then | 23 | if Vector.length col == 4 then |
24 | glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) | 24 | glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) |
25 | (unsafeCoerce $ w col) | 25 | (unsafeCoerce $ w col) |
26 | else | 26 | else |
27 | glColor3f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) | 27 | glColor3f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) |
28 | 28 | ||
29 | 29 | ||
30 | -- | Renders a sphere. | 30 | -- | Renders a sphere. |
31 | -- Center is the sphere's center. | 31 | -- Center is the sphere's center. |
32 | -- Radius is the sphere's radius. | 32 | -- Radius is the sphere's radius. |
33 | -- Colour is a Vector representing the sphere's colour. Colour may hold an alpha channel. | 33 | -- Colour is a Vector representing the sphere's colour. Colour may hold an alpha channel. |
34 | render :: Center -> Radius -> Colour -> IO () | 34 | render :: Center -> Radius -> Colour -> IO () |
35 | render c radius col = do | 35 | render c radius col = do |
36 | glPushMatrix | 36 | glPushMatrix |
37 | glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) | 37 | glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) |
38 | applyColour col | 38 | applyColour col |
39 | 39 | ||
40 | let r = unsafeCoerce $ (realToFrac radius :: Double) | 40 | let r = unsafeCoerce $ (realToFrac radius :: Double) |
41 | let style = GLU.QuadricStyle (Just Smooth) GLU.NoTextureCoordinates GLU.Outside GLU.FillStyle | 41 | let style = GLU.QuadricStyle (Just Smooth) GLU.NoTextureCoordinates GLU.Outside GLU.FillStyle |
42 | GLU.renderQuadric style $ GLU.Sphere r 16 16 | 42 | GLU.renderQuadric style $ GLU.Sphere r 16 16 |
43 | 43 | ||
44 | glPopMatrix | 44 | glPopMatrix |
45 | \ No newline at end of file | 45 | \ No newline at end of file |
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs index 2f74c06..2e9804f 100644 --- a/Spear/Render/StaticModel.hs +++ b/Spear/Render/StaticModel.hs | |||
@@ -1,138 +1,138 @@ | |||
1 | module Spear.Render.StaticModel | 1 | module Spear.Render.StaticModel |
2 | ( | 2 | ( |
3 | -- * Data types | 3 | -- * Data types |
4 | StaticModelResource | 4 | StaticModelResource |
5 | , StaticModelRenderer | 5 | , StaticModelRenderer |
6 | -- * Construction and destruction | 6 | -- * Construction and destruction |
7 | , staticModelResource | 7 | , staticModelResource |
8 | , staticModelRenderer | 8 | , staticModelRenderer |
9 | -- * Manipulation | 9 | -- * Manipulation |
10 | , box | 10 | , box |
11 | , modelRes | 11 | , modelRes |
12 | -- * Rendering | 12 | -- * Rendering |
13 | , bind | 13 | , bind |
14 | , render | 14 | , render |
15 | -- * Collision | 15 | -- * Collision |
16 | , mkColsFromStatic | 16 | , mkColsFromStatic |
17 | ) | 17 | ) |
18 | where | 18 | where |
19 | 19 | ||
20 | import Spear.Assets.Model | 20 | import Spear.Assets.Model |
21 | import Spear.Game | 21 | import Spear.Game |
22 | import Spear.GL | 22 | import Spear.GL |
23 | import Spear.Math.AABB | 23 | import Spear.Math.AABB |
24 | import Spear.Math.Collision | 24 | import Spear.Math.Collision |
25 | import Spear.Math.Matrix4 (Matrix4) | 25 | import Spear.Math.Matrix4 (Matrix4) |
26 | import Spear.Math.Vector | 26 | import Spear.Math.Vector |
27 | import Spear.Render.Material | 27 | import Spear.Render.Material |
28 | import Spear.Render.Model | 28 | import Spear.Render.Model |
29 | import Spear.Render.Program | 29 | import Spear.Render.Program |
30 | 30 | ||
31 | import qualified Data.Vector as V | 31 | import qualified Data.Vector as V |
32 | import Unsafe.Coerce (unsafeCoerce) | 32 | import Unsafe.Coerce (unsafeCoerce) |
33 | 33 | ||
34 | data StaticModelResource = StaticModelResource | 34 | data StaticModelResource = StaticModelResource |
35 | { vao :: VAO | 35 | { vao :: VAO |
36 | , nVertices :: Int | 36 | , nVertices :: Int |
37 | , material :: Material | 37 | , material :: Material |
38 | , texture :: Texture | 38 | , texture :: Texture |
39 | , boxes :: V.Vector Box | 39 | , boxes :: V.Vector Box |
40 | , rkey :: Resource | 40 | , rkey :: Resource |
41 | } | 41 | } |
42 | 42 | ||
43 | instance Eq StaticModelResource where | 43 | instance Eq StaticModelResource where |
44 | m1 == m2 = vao m1 == vao m2 | 44 | m1 == m2 = vao m1 == vao m2 |
45 | 45 | ||
46 | instance Ord StaticModelResource where | 46 | instance Ord StaticModelResource where |
47 | m1 < m2 = vao m1 < vao m2 | 47 | m1 < m2 = vao m1 < vao m2 |
48 | 48 | ||
49 | instance ResourceClass StaticModelResource where | 49 | instance ResourceClass StaticModelResource where |
50 | getResource = rkey | 50 | getResource = rkey |
51 | 51 | ||
52 | data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } | 52 | data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } |
53 | 53 | ||
54 | instance Eq StaticModelRenderer where | 54 | instance Eq StaticModelRenderer where |
55 | m1 == m2 = model m1 == model m2 | 55 | m1 == m2 = model m1 == model m2 |
56 | 56 | ||
57 | instance Ord StaticModelRenderer where | 57 | instance Ord StaticModelRenderer where |
58 | m1 < m2 = model m1 < model m2 | 58 | m1 < m2 = model m1 < model m2 |
59 | 59 | ||
60 | -- | Create a model resource from the given model. | 60 | -- | Create a model resource from the given model. |
61 | staticModelResource :: StaticProgramChannels | 61 | staticModelResource :: StaticProgramChannels |
62 | -> Material | 62 | -> Material |
63 | -> Texture | 63 | -> Texture |
64 | -> Model | 64 | -> Model |
65 | -> Game s StaticModelResource | 65 | -> Game s StaticModelResource |
66 | 66 | ||
67 | staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do | 67 | staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do |
68 | RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model | 68 | RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model |
69 | elementBuf <- newBuffer | 69 | elementBuf <- newBuffer |
70 | vao <- newVAO | 70 | vao <- newVAO |
71 | boxes <- gameIO $ modelBoxes model | 71 | boxes <- gameIO $ modelBoxes model |
72 | 72 | ||
73 | gameIO $ do | 73 | gameIO $ do |
74 | 74 | ||
75 | let elemSize = 32 | 75 | let elemSize = 32 |
76 | elemSize' = fromIntegral elemSize | 76 | elemSize' = fromIntegral elemSize |
77 | n = numVertices | 77 | n = numVertices |
78 | 78 | ||
79 | bindVAO vao | 79 | bindVAO vao |
80 | 80 | ||
81 | bindBuffer elementBuf ArrayBuffer | 81 | bindBuffer ArrayBuffer elementBuf |
82 | bufferData' ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw | 82 | bufferData' ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw |
83 | 83 | ||
84 | attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0 | 84 | attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0 |
85 | attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12 | 85 | attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12 |
86 | attribVAOPointer texChan 2 gl_FLOAT False elemSize' 24 | 86 | attribVAOPointer texChan 2 gl_FLOAT False elemSize' 24 |
87 | 87 | ||
88 | enableVAOAttrib vertChan | 88 | enableVAOAttrib vertChan |
89 | enableVAOAttrib normChan | 89 | enableVAOAttrib normChan |
90 | enableVAOAttrib texChan | 90 | enableVAOAttrib texChan |
91 | 91 | ||
92 | rkey <- register $ do | 92 | rkey <- register $ do |
93 | putStrLn "Releasing static model resource" | 93 | putStrLn "Releasing static model resource" |
94 | clean vao | 94 | clean vao |
95 | clean elementBuf | 95 | clean elementBuf |
96 | 96 | ||
97 | return $ StaticModelResource | 97 | return $ StaticModelResource |
98 | vao (unsafeCoerce numVertices) material texture boxes rkey | 98 | vao (unsafeCoerce numVertices) material texture boxes rkey |
99 | 99 | ||
100 | -- | Create a renderer from the given model resource. | 100 | -- | Create a renderer from the given model resource. |
101 | staticModelRenderer :: StaticModelResource -> StaticModelRenderer | 101 | staticModelRenderer :: StaticModelResource -> StaticModelRenderer |
102 | staticModelRenderer = StaticModelRenderer | 102 | staticModelRenderer = StaticModelRenderer |
103 | 103 | ||
104 | -- | Get the model's ith bounding box. | 104 | -- | Get the model's ith bounding box. |
105 | box :: Int -> StaticModelResource -> Box | 105 | box :: Int -> StaticModelResource -> Box |
106 | box i model = boxes model V.! i | 106 | box i model = boxes model V.! i |
107 | 107 | ||
108 | -- | Get the renderer's model resource. | 108 | -- | Get the renderer's model resource. |
109 | modelRes :: StaticModelRenderer -> StaticModelResource | 109 | modelRes :: StaticModelRenderer -> StaticModelResource |
110 | modelRes = model | 110 | modelRes = model |
111 | 111 | ||
112 | -- | Bind the given renderer to prepare it for rendering. | 112 | -- | Bind the given renderer to prepare it for rendering. |
113 | bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () | 113 | bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () |
114 | bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = | 114 | bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = |
115 | let (Material _ ka kd ks shi) = material model | 115 | let (Material _ ka kd ks shi) = material model |
116 | in do | 116 | in do |
117 | bindVAO . vao $ model | 117 | bindVAO . vao $ model |
118 | bindTexture $ texture model | 118 | bindTexture $ texture model |
119 | activeTexture $= gl_TEXTURE0 | 119 | activeTexture $= gl_TEXTURE0 |
120 | glUniform1i texLoc 0 | 120 | glUniform1i texLoc 0 |
121 | 121 | ||
122 | -- | Render the given renderer. | 122 | -- | Render the given renderer. |
123 | render :: StaticProgramUniforms -> StaticModelRenderer -> IO () | 123 | render :: StaticProgramUniforms -> StaticModelRenderer -> IO () |
124 | render uniforms (StaticModelRenderer model) = | 124 | render uniforms (StaticModelRenderer model) = |
125 | let (Material _ ka kd ks shi) = material model | 125 | let (Material _ ka kd ks shi) = material model |
126 | in do | 126 | in do |
127 | uniform (kaLoc uniforms) ka | 127 | uniform (kaLoc uniforms) ka |
128 | uniform (kdLoc uniforms) kd | 128 | uniform (kdLoc uniforms) kd |
129 | uniform (ksLoc uniforms) ks | 129 | uniform (ksLoc uniforms) ks |
130 | glUniform1f (shiLoc uniforms) $ unsafeCoerce shi | 130 | glUniform1f (shiLoc uniforms) $ unsafeCoerce shi |
131 | drawArrays gl_TRIANGLES 0 $ nVertices model | 131 | drawArrays gl_TRIANGLES 0 $ nVertices model |
132 | 132 | ||
133 | -- | Compute AABB collisioners in view space from the given model. | 133 | -- | Compute AABB collisioners in view space from the given model. |
134 | mkColsFromStatic | 134 | mkColsFromStatic |
135 | :: Matrix4 -- ^ Modelview matrix | 135 | :: Matrix4 -- ^ Modelview matrix |
136 | -> StaticModelResource | 136 | -> StaticModelResource |
137 | -> [Collisioner2] | 137 | -> [Collisioner2] |
138 | mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) | 138 | mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) |
diff --git a/Spear/Render/Triangle.hs b/Spear/Render/Triangle.hs index 08a2c01..49f4418 100644 --- a/Spear/Render/Triangle.hs +++ b/Spear/Render/Triangle.hs | |||
@@ -1,8 +1,8 @@ | |||
1 | module Spear.Render.Triangle | 1 | module Spear.Render.Triangle |
2 | ( | 2 | ( |
3 | ) | 3 | ) |
4 | where | 4 | where |
5 | 5 | ||
6 | 6 | ||
7 | import Spear.GL | 7 | import Spear.GL |
8 | 8 | ||
diff --git a/Spear/Scene/GameObject.hs b/Spear/Scene/GameObject.hs index 5ea483b..f9fd667 100644 --- a/Spear/Scene/GameObject.hs +++ b/Spear/Scene/GameObject.hs | |||
@@ -1,320 +1,320 @@ | |||
1 | module Spear.Scene.GameObject | 1 | module Spear.Scene.GameObject |
2 | ( | 2 | ( |
3 | GameObject | 3 | GameObject |
4 | , GameStyle(..) | 4 | , GameStyle(..) |
5 | , Window(..) | 5 | , Window(..) |
6 | , AM.AnimationSpeed | 6 | , AM.AnimationSpeed |
7 | -- * Construction | 7 | -- * Construction |
8 | , goNew | 8 | , goNew |
9 | -- * Accessors | 9 | -- * Accessors |
10 | , currentAnimation | 10 | , currentAnimation |
11 | --, goAABB | 11 | --, goAABB |
12 | --, goAABBs | 12 | --, goAABBs |
13 | , collisioners | 13 | , collisioners |
14 | , goRPGtransform | 14 | , goRPGtransform |
15 | , numCollisioners | 15 | , numCollisioners |
16 | , renderer | 16 | , renderer |
17 | , window | 17 | , window |
18 | -- * Manipulation | 18 | -- * Manipulation |
19 | , goUpdate | 19 | , goUpdate |
20 | , setAnimation | 20 | , setAnimation |
21 | , setAnimationSpeed | 21 | , setAnimationSpeed |
22 | , setAxis | 22 | , setAxis |
23 | , withCollisioners | 23 | , withCollisioners |
24 | , setCollisioners | 24 | , setCollisioners |
25 | , setWindow | 25 | , setWindow |
26 | -- * Rendering | 26 | -- * Rendering |
27 | , goRender | 27 | , goRender |
28 | -- * Collision | 28 | -- * Collision |
29 | , goCollide | 29 | , goCollide |
30 | ) | 30 | ) |
31 | where | 31 | where |
32 | 32 | ||
33 | 33 | ||
34 | import Spear.GL | 34 | import Spear.GL |
35 | import Spear.Math.AABB | 35 | import Spear.Math.AABB |
36 | import qualified Spear.Math.Camera as Cam | 36 | import qualified Spear.Math.Camera as Cam |
37 | import Spear.Math.Collision as Col | 37 | import Spear.Math.Collision as Col |
38 | import qualified Spear.Math.Matrix3 as M3 | 38 | import qualified Spear.Math.Matrix3 as M3 |
39 | import qualified Spear.Math.Matrix4 as M4 | 39 | import qualified Spear.Math.Matrix4 as M4 |
40 | import Spear.Math.MatrixUtils | 40 | import Spear.Math.MatrixUtils |
41 | import qualified Spear.Math.Spatial2 as S2 | 41 | import qualified Spear.Math.Spatial2 as S2 |
42 | import qualified Spear.Math.Spatial3 as S3 | 42 | import qualified Spear.Math.Spatial3 as S3 |
43 | import Spear.Math.Utils | 43 | import Spear.Math.Utils |
44 | import Spear.Math.Vector | 44 | import Spear.Math.Vector |
45 | import qualified Spear.Render.AnimatedModel as AM | 45 | import qualified Spear.Render.AnimatedModel as AM |
46 | import Spear.Render.Program | 46 | import Spear.Render.Program |
47 | import Spear.Render.StaticModel as SM | 47 | import Spear.Render.StaticModel as SM |
48 | 48 | ||
49 | import Data.Fixed (mod') | 49 | import Data.Fixed (mod') |
50 | import Data.List (foldl') | 50 | import Data.List (foldl') |
51 | 51 | ||
52 | 52 | ||
53 | -- | Game style. | 53 | -- | Game style. |
54 | data GameStyle | 54 | data GameStyle |
55 | = RPG -- ^ RPG or RTS style game. | 55 | = RPG -- ^ RPG or RTS style game. |
56 | | PLT -- ^ Platformer or space invaders style game. | 56 | | PLT -- ^ Platformer or space invaders style game. |
57 | 57 | ||
58 | 58 | ||
59 | data Window = Window | 59 | data Window = Window |
60 | { projInv :: !M4.Matrix4 | 60 | { projInv :: !M4.Matrix4 |
61 | , viewInv :: !M4.Matrix4 | 61 | , viewInv :: !M4.Matrix4 |
62 | , vpx :: !Float | 62 | , vpx :: !Float |
63 | , vpy :: !Float | 63 | , vpy :: !Float |
64 | , width :: !Float | 64 | , width :: !Float |
65 | , height :: !Float | 65 | , height :: !Float |
66 | } | 66 | } |
67 | 67 | ||
68 | 68 | ||
69 | dummyWindow = Window M4.id M4.id 0 0 640 480 | 69 | dummyWindow = Window M4.id M4.id 0 0 640 480 |
70 | 70 | ||
71 | 71 | ||
72 | -- | An object in the game scene. | 72 | -- | An object in the game scene. |
73 | data GameObject = GameObject | 73 | data GameObject = GameObject |
74 | { gameStyle :: !GameStyle | 74 | { gameStyle :: !GameStyle |
75 | , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) | 75 | , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) |
76 | , collisioners :: ![Collisioner2] | 76 | , collisioners :: ![Collisioner2] |
77 | , transform :: !M3.Matrix3 | 77 | , transform :: !M3.Matrix3 |
78 | , axis :: !Vector3 | 78 | , axis :: !Vector3 |
79 | , angle :: !Float | 79 | , angle :: !Float |
80 | , window :: !Window | 80 | , window :: !Window |
81 | } | 81 | } |
82 | 82 | ||
83 | 83 | ||
84 | instance S2.Spatial2 GameObject where | 84 | instance S2.Spatial2 GameObject where |
85 | 85 | ||
86 | move v go = go | 86 | move v go = go |
87 | { collisioners = fmap (Col.move v) $ collisioners go | 87 | { collisioners = fmap (Col.move v) $ collisioners go |
88 | , transform = M3.translv v * transform go | 88 | , transform = M3.translv v * transform go |
89 | } | 89 | } |
90 | 90 | ||
91 | moveFwd s go = | 91 | moveFwd s go = |
92 | let m = transform go | 92 | let m = transform go |
93 | v = scale s $ M3.forward m | 93 | v = scale s $ M3.forward m |
94 | in go | 94 | in go |
95 | { collisioners = fmap (Col.move v) $ collisioners go | 95 | { collisioners = fmap (Col.move v) $ collisioners go |
96 | , transform = M3.translv v * m | 96 | , transform = M3.translv v * m |
97 | } | 97 | } |
98 | 98 | ||
99 | moveBack s go = | 99 | moveBack s go = |
100 | let m = transform go | 100 | let m = transform go |
101 | v = scale (-s) $ M3.forward m | 101 | v = scale (-s) $ M3.forward m |
102 | in go | 102 | in go |
103 | { collisioners = fmap (Col.move v) $ collisioners go | 103 | { collisioners = fmap (Col.move v) $ collisioners go |
104 | , transform = M3.translv v * m | 104 | , transform = M3.translv v * m |
105 | } | 105 | } |
106 | 106 | ||
107 | strafeLeft s go = | 107 | strafeLeft s go = |
108 | let m = transform go | 108 | let m = transform go |
109 | v = scale (-s) $ M3.right m | 109 | v = scale (-s) $ M3.right m |
110 | in go | 110 | in go |
111 | { collisioners = fmap (Col.move v) $ collisioners go | 111 | { collisioners = fmap (Col.move v) $ collisioners go |
112 | , transform = M3.translv v * m | 112 | , transform = M3.translv v * m |
113 | } | 113 | } |
114 | 114 | ||
115 | strafeRight s go = | 115 | strafeRight s go = |
116 | let m = transform go | 116 | let m = transform go |
117 | v = scale s $ M3.right m | 117 | v = scale s $ M3.right m |
118 | in go | 118 | in go |
119 | { collisioners = fmap (Col.move v) $ collisioners go | 119 | { collisioners = fmap (Col.move v) $ collisioners go |
120 | , transform = M3.translv v * m | 120 | , transform = M3.translv v * m |
121 | } | 121 | } |
122 | 122 | ||
123 | rotate a go = | 123 | rotate a go = |
124 | go | 124 | go |
125 | { transform = transform go * M3.rot a | 125 | { transform = transform go * M3.rot a |
126 | , angle = (angle go + a) `mod'` 360 | 126 | , angle = (angle go + a) `mod'` 360 |
127 | } | 127 | } |
128 | 128 | ||
129 | setRotation a go = | 129 | setRotation a go = |
130 | go | 130 | go |
131 | { transform = M3.translation (transform go) * M3.rot a | 131 | { transform = M3.translation (transform go) * M3.rot a |
132 | , angle = a | 132 | , angle = a |
133 | } | 133 | } |
134 | 134 | ||
135 | pos go = M3.position . transform $ go | 135 | pos go = M3.position . transform $ go |
136 | 136 | ||
137 | fwd go = M3.forward . transform $ go | 137 | fwd go = M3.forward . transform $ go |
138 | 138 | ||
139 | up go = M3.up . transform $ go | 139 | up go = M3.up . transform $ go |
140 | 140 | ||
141 | right go = M3.right . transform $ go | 141 | right go = M3.right . transform $ go |
142 | 142 | ||
143 | transform go = Spear.Scene.GameObject.transform go | 143 | transform go = Spear.Scene.GameObject.transform go |
144 | 144 | ||
145 | setTransform mat go = go { transform = mat } | 145 | setTransform mat go = go { transform = mat } |
146 | 146 | ||
147 | setPos pos go = | 147 | setPos pos go = |
148 | let m = transform go | 148 | let m = transform go |
149 | in go { transform = M3.transform (M3.right m) (M3.forward m) pos } | 149 | in go { transform = M3.transform (M3.right m) (M3.forward m) pos } |
150 | 150 | ||
151 | lookAt p go = | 151 | lookAt p go = |
152 | let position = S2.pos go | 152 | let position = S2.pos go |
153 | fwd = normalise $ p - position | 153 | fwd = normalise $ p - position |
154 | r = perp fwd | 154 | r = perp fwd |
155 | toDeg = (*(180/pi)) | 155 | toDeg = (*(180/pi)) |
156 | viewI = viewInv . window $ go | 156 | viewI = viewInv . window $ go |
157 | p1 = viewToWorld2d position viewI | 157 | p1 = viewToWorld2d position viewI |
158 | p2 = viewToWorld2d (position + fwd) viewI | 158 | p2 = viewToWorld2d (position + fwd) viewI |
159 | f = normalise $ p2 - p1 | 159 | f = normalise $ p2 - p1 |
160 | in | 160 | in |
161 | go | 161 | go |
162 | { transform = M3.transform r fwd position | 162 | { transform = M3.transform r fwd position |
163 | , angle = 180 - | 163 | , angle = 180 - |
164 | if x f > 0 | 164 | if x f > 0 |
165 | then toDeg . acos $ f `dot` unity2 | 165 | then toDeg . acos $ f `dot` unity2 |
166 | else (+180) . toDeg . acos $ f `dot` (-unity2) | 166 | else (+180) . toDeg . acos $ f `dot` (-unity2) |
167 | } | 167 | } |
168 | 168 | ||
169 | 169 | ||
170 | -- | Create a new game object. | 170 | -- | Create a new game object. |
171 | goNew :: GameStyle | 171 | goNew :: GameStyle |
172 | -> Either StaticModelResource AM.AnimatedModelResource | 172 | -> Either StaticModelResource AM.AnimatedModelResource |
173 | -> [Collisioner2] | 173 | -> [Collisioner2] |
174 | -> M3.Matrix3 -- ^ Transform | 174 | -> M3.Matrix3 -- ^ Transform |
175 | -> Vector3 -- ^ Axis of rotation | 175 | -> Vector3 -- ^ Axis of rotation |
176 | -> GameObject | 176 | -> GameObject |
177 | 177 | ||
178 | goNew style (Left smr) cols transf axis = GameObject | 178 | goNew style (Left smr) cols transf axis = GameObject |
179 | style (Left $ SM.staticModelRenderer smr) cols transf axis 0 dummyWindow | 179 | style (Left $ SM.staticModelRenderer smr) cols transf axis 0 dummyWindow |
180 | 180 | ||
181 | goNew style (Right amr) cols transf axis = GameObject | 181 | goNew style (Right amr) cols transf axis = GameObject |
182 | style (Right $ AM.animatedModelRenderer 1 amr) cols transf axis 0 dummyWindow | 182 | style (Right $ AM.animatedModelRenderer 1 amr) cols transf axis 0 dummyWindow |
183 | 183 | ||
184 | 184 | ||
185 | goUpdate :: Float -> GameObject -> GameObject | 185 | goUpdate :: Float -> GameObject -> GameObject |
186 | goUpdate dt go = | 186 | goUpdate dt go = |
187 | let rend = renderer go | 187 | let rend = renderer go |
188 | rend' = case rend of | 188 | rend' = case rend of |
189 | Left _ -> rend | 189 | Left _ -> rend |
190 | Right amr -> Right $ AM.update dt amr | 190 | Right amr -> Right $ AM.update dt amr |
191 | in go | 191 | in go |
192 | { renderer = rend' | 192 | { renderer = rend' |
193 | } | 193 | } |
194 | 194 | ||
195 | 195 | ||
196 | -- | Get the game object's ith bounding box. | 196 | -- | Get the game object's ith bounding box. |
197 | --goAABB :: Int -> GameObject -> AABB2 | 197 | --goAABB :: Int -> GameObject -> AABB2 |
198 | --goAABB i = getAABB . flip (!!) i . collisioners | 198 | --goAABB i = getAABB . flip (!!) i . collisioners |
199 | 199 | ||
200 | 200 | ||
201 | -- | Get the game object's bounding boxes. | 201 | -- | Get the game object's bounding boxes. |
202 | --goAABBs :: GameObject -> [AABB2] | 202 | --goAABBs :: GameObject -> [AABB2] |
203 | --goAABBs = fmap getAABB . collisioners | 203 | --goAABBs = fmap getAABB . collisioners |
204 | 204 | ||
205 | 205 | ||
206 | -- | Get the game object's 3D transform. | 206 | -- | Get the game object's 3D transform. |
207 | goRPGtransform :: GameObject -> M4.Matrix4 | 207 | goRPGtransform :: GameObject -> M4.Matrix4 |
208 | goRPGtransform go = | 208 | goRPGtransform go = |
209 | let viewI = viewInv . window $ go | 209 | let viewI = viewInv . window $ go |
210 | in rpgTransform 0 (angle go) (axis go) (S2.pos go) viewI | 210 | in rpgTransform 0 (angle go) (axis go) (S2.pos go) viewI |
211 | 211 | ||
212 | 212 | ||
213 | -- | Get the game object's current animation. | 213 | -- | Get the game object's current animation. |
214 | currentAnimation :: Enum a => GameObject -> a | 214 | currentAnimation :: Enum a => GameObject -> a |
215 | currentAnimation go = case renderer go of | 215 | currentAnimation go = case renderer go of |
216 | Left _ -> toEnum 0 | 216 | Left _ -> toEnum 0 |
217 | Right amr -> AM.currentAnimation amr | 217 | Right amr -> AM.currentAnimation amr |
218 | 218 | ||
219 | 219 | ||
220 | -- | Return the game object's number of collisioners. | 220 | -- | Return the game object's number of collisioners. |
221 | numCollisioners :: GameObject -> Int | 221 | numCollisioners :: GameObject -> Int |
222 | numCollisioners = length . collisioners | 222 | numCollisioners = length . collisioners |
223 | 223 | ||
224 | 224 | ||
225 | -- | Set the game object's current animation. | 225 | -- | Set the game object's current animation. |
226 | setAnimation :: Enum a => a -> GameObject -> GameObject | 226 | setAnimation :: Enum a => a -> GameObject -> GameObject |
227 | setAnimation a go = case renderer go of | 227 | setAnimation a go = case renderer go of |
228 | Left _ -> go | 228 | Left _ -> go |
229 | Right amr -> go { renderer = Right $ AM.setAnimation a amr } | 229 | Right amr -> go { renderer = Right $ AM.setAnimation a amr } |
230 | 230 | ||
231 | 231 | ||
232 | -- | Set the game object's animation speed. | 232 | -- | Set the game object's animation speed. |
233 | setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject | 233 | setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject |
234 | setAnimationSpeed s go = case renderer go of | 234 | setAnimationSpeed s go = case renderer go of |
235 | Left _ -> go | 235 | Left _ -> go |
236 | Right amr -> go { renderer = Right $ AM.setAnimationSpeed s amr } | 236 | Right amr -> go { renderer = Right $ AM.setAnimationSpeed s amr } |
237 | 237 | ||
238 | 238 | ||
239 | -- | Set the game object's axis of rotation. | 239 | -- | Set the game object's axis of rotation. |
240 | setAxis :: Vector3 -> GameObject -> GameObject | 240 | setAxis :: Vector3 -> GameObject -> GameObject |
241 | setAxis ax go = go { axis = ax } | 241 | setAxis ax go = go { axis = ax } |
242 | 242 | ||
243 | 243 | ||
244 | -- | Set the game object's collisioners. | 244 | -- | Set the game object's collisioners. |
245 | setCollisioners :: [Collisioner2] -> GameObject -> GameObject | 245 | setCollisioners :: [Collisioner2] -> GameObject -> GameObject |
246 | setCollisioners cols go = go { collisioners = cols } | 246 | setCollisioners cols go = go { collisioners = cols } |
247 | 247 | ||
248 | 248 | ||
249 | -- | Set the game object's window. | 249 | -- | Set the game object's window. |
250 | setWindow :: Window -> GameObject -> GameObject | 250 | setWindow :: Window -> GameObject -> GameObject |
251 | setWindow wnd go = go { window = wnd } | 251 | setWindow wnd go = go { window = wnd } |
252 | 252 | ||
253 | 253 | ||
254 | -- | Manipulate the game object's collisioners. | 254 | -- | Manipulate the game object's collisioners. |
255 | withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject | 255 | withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject |
256 | withCollisioners go f = go { collisioners = f $ collisioners go } | 256 | withCollisioners go f = go { collisioners = f $ collisioners go } |
257 | 257 | ||
258 | 258 | ||
259 | -- | Render the game object. | 259 | -- | Render the game object. |
260 | goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO () | 260 | goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO () |
261 | goRender sprog aprog cam go = | 261 | goRender sprog aprog cam go = |
262 | let spu = staticProgramUniforms sprog | 262 | let spu = staticProgramUniforms sprog |
263 | apu = animatedProgramUniforms aprog | 263 | apu = animatedProgramUniforms aprog |
264 | style = gameStyle go | 264 | style = gameStyle go |
265 | axis' = axis go | 265 | axis' = axis go |
266 | a = angle go | 266 | a = angle go |
267 | proj = Cam.projection cam | 267 | proj = Cam.projection cam |
268 | view = M4.inverseTransform $ S3.transform cam | 268 | view = M4.inverseTransform $ S3.transform cam |
269 | transf = S2.transform go | 269 | transf = S2.transform go |
270 | normal = fastNormalMatrix modelview | 270 | normal = fastNormalMatrix modelview |
271 | modelview = case style of | 271 | modelview = case style of |
272 | RPG -> view * goRPGtransform go | 272 | RPG -> view * goRPGtransform go |
273 | PLT -> view * pltTransform transf | 273 | PLT -> view * pltTransform transf |
274 | in case renderer go of | 274 | in case renderer go of |
275 | Left smr -> | 275 | Left smr -> |
276 | goRender' style a axis' sprog spu modelview proj normal | 276 | goRender' style a axis' sprog spu modelview proj normal |
277 | (SM.bind spu smr) (SM.render spu smr) | 277 | (SM.bind spu smr) (SM.render spu smr) |
278 | Right amr -> | 278 | Right amr -> |
279 | goRender' style a axis' aprog apu modelview proj normal | 279 | goRender' style a axis' aprog apu modelview proj normal |
280 | (AM.bind apu amr) (AM.render apu amr) | 280 | (AM.bind apu amr) (AM.render apu amr) |
281 | 281 | ||
282 | 282 | ||
283 | type Bind = IO () | 283 | type Bind = IO () |
284 | 284 | ||
285 | type Render = IO () | 285 | type Render = IO () |
286 | 286 | ||
287 | 287 | ||
288 | goRender' :: (ProgramUniforms u, Program p) | 288 | goRender' :: (ProgramUniforms u, Program p) |
289 | => GameStyle | 289 | => GameStyle |
290 | -> Float | 290 | -> Float |
291 | -> Vector3 | 291 | -> Vector3 |
292 | -> p | 292 | -> p |
293 | -> u | 293 | -> u |
294 | -> M4.Matrix4 -- Modelview | 294 | -> M4.Matrix4 -- Modelview |
295 | -> M4.Matrix4 -- Projection | 295 | -> M4.Matrix4 -- Projection |
296 | -> M3.Matrix3 -- Normal matrix | 296 | -> M3.Matrix3 -- Normal matrix |
297 | -> Bind | 297 | -> Bind |
298 | -> Render | 298 | -> Render |
299 | -> IO () | 299 | -> IO () |
300 | goRender' style a axis prog uniforms modelview proj normal bindRenderer render = | 300 | goRender' style a axis prog uniforms modelview proj normal bindRenderer render = |
301 | let | 301 | let |
302 | in do | 302 | in do |
303 | useProgram . program $ prog | 303 | useProgram . program $ prog |
304 | uniform (projLoc uniforms) proj | 304 | uniform (projLoc uniforms) proj |
305 | uniform (modelviewLoc uniforms) modelview | 305 | uniform (modelviewLoc uniforms) modelview |
306 | uniform (normalmatLoc uniforms) normal | 306 | uniform (normalmatLoc uniforms) normal |
307 | bindRenderer | 307 | bindRenderer |
308 | render | 308 | render |
309 | 309 | ||
310 | 310 | ||
311 | -- | Return 'True' if the given game objects collide, 'False' otherwise. | 311 | -- | Return 'True' if the given game objects collide, 'False' otherwise. |
312 | goCollide :: GameObject -> GameObject -> Bool | 312 | goCollide :: GameObject -> GameObject -> Bool |
313 | goCollide go1 go2 = | 313 | goCollide go1 go2 = |
314 | let cols1 = collisioners go1 | 314 | let cols1 = collisioners go1 |
315 | cols2 = collisioners go2 | 315 | cols2 = collisioners go2 |
316 | c1 = cols1 !! 0 | 316 | c1 = cols1 !! 0 |
317 | c2 = cols2 !! 0 | 317 | c2 = cols2 !! 0 |
318 | in | 318 | in |
319 | if length cols1 == 0 || length cols2 == 0 then False | 319 | if length cols1 == 0 || length cols2 == 0 then False |
320 | else c1 `collide` c2 /= NoCollision | 320 | else c1 `collide` c2 /= NoCollision |
diff --git a/Spear/Scene/Graph.hs b/Spear/Scene/Graph.hs index a91fc89..8f8b5f9 100644 --- a/Spear/Scene/Graph.hs +++ b/Spear/Scene/Graph.hs | |||
@@ -1,143 +1,143 @@ | |||
1 | module Spear.Scene.Graph | 1 | module Spear.Scene.Graph |
2 | ( | 2 | ( |
3 | Property | 3 | Property |
4 | , SceneGraph(..) | 4 | , SceneGraph(..) |
5 | , ParseError | 5 | , ParseError |
6 | , loadSceneGraph | 6 | , loadSceneGraph |
7 | , loadSceneGraphFromFile | 7 | , loadSceneGraphFromFile |
8 | , node | 8 | , node |
9 | ) | 9 | ) |
10 | where | 10 | where |
11 | 11 | ||
12 | 12 | ||
13 | import qualified Data.ByteString.Char8 as B | 13 | import qualified Data.ByteString.Char8 as B |
14 | import Data.List (find, intersperse) | 14 | import Data.List (find, intersperse) |
15 | import Data.Maybe (isJust) | 15 | import Data.Maybe (isJust) |
16 | import Text.Parsec.Char | 16 | import Text.Parsec.Char |
17 | import Text.Parsec.Combinator | 17 | import Text.Parsec.Combinator |
18 | import Text.Parsec.Error | 18 | import Text.Parsec.Error |
19 | import Text.Parsec.Prim | 19 | import Text.Parsec.Prim |
20 | import qualified Text.Parsec.ByteString as P | 20 | import qualified Text.Parsec.ByteString as P |
21 | import qualified Text.Parsec.Token as PT | 21 | import qualified Text.Parsec.Token as PT |
22 | 22 | ||
23 | 23 | ||
24 | type Property = (String, [String]) | 24 | type Property = (String, [String]) |
25 | 25 | ||
26 | 26 | ||
27 | data SceneGraph | 27 | data SceneGraph |
28 | = SceneNode | 28 | = SceneNode |
29 | { nodeID :: String | 29 | { nodeID :: String |
30 | , properties :: [Property] | 30 | , properties :: [Property] |
31 | , children :: [SceneGraph] | 31 | , children :: [SceneGraph] |
32 | } | 32 | } |
33 | | SceneLeaf | 33 | | SceneLeaf |
34 | { nodeID :: String | 34 | { nodeID :: String |
35 | , properties :: [Property] | 35 | , properties :: [Property] |
36 | } | 36 | } |
37 | 37 | ||
38 | 38 | ||
39 | instance Show SceneGraph where | 39 | instance Show SceneGraph where |
40 | show sceneGraph = show' "" sceneGraph | 40 | show sceneGraph = show' "" sceneGraph |
41 | where | 41 | where |
42 | show' tab (SceneNode nid props children) = | 42 | show' tab (SceneNode nid props children) = |
43 | tab ++ nid ++ "\n" ++ tab ++ "{\n" ++ (printProps tab props) ++ | 43 | tab ++ nid ++ "\n" ++ tab ++ "{\n" ++ (printProps tab props) ++ |
44 | (concat . fmap (show' $ " " ++ tab) $ children) ++ '\n':tab ++ "}\n" | 44 | (concat . fmap (show' $ " " ++ tab) $ children) ++ '\n':tab ++ "}\n" |
45 | 45 | ||
46 | show' tab (SceneLeaf nid props) = | 46 | show' tab (SceneLeaf nid props) = |
47 | tab ++ nid ++ '\n':tab ++ "{\n" ++ tab ++ (printProps tab props) ++ '\n':tab ++ "}\n" | 47 | tab ++ nid ++ '\n':tab ++ "{\n" ++ tab ++ (printProps tab props) ++ '\n':tab ++ "}\n" |
48 | 48 | ||
49 | 49 | ||
50 | printProp :: Property -> String | 50 | printProp :: Property -> String |
51 | printProp (key, vals) = key ++ " = " ++ (concat $ intersperse ", " vals) | 51 | printProp (key, vals) = key ++ " = " ++ (concat $ intersperse ", " vals) |
52 | 52 | ||
53 | 53 | ||
54 | printProps :: String -> [Property] -> String | 54 | printProps :: String -> [Property] -> String |
55 | printProps tab props = | 55 | printProps tab props = |
56 | let | 56 | let |
57 | tab' = '\n':(tab ++ tab) | 57 | tab' = '\n':(tab ++ tab) |
58 | longestKeyLen = maximum . fmap (length . fst) $ props | 58 | longestKeyLen = maximum . fmap (length . fst) $ props |
59 | 59 | ||
60 | align :: Int -> String -> String | 60 | align :: Int -> String -> String |
61 | align len str = | 61 | align len str = |
62 | let (key, vals) = break ((==) '=') str | 62 | let (key, vals) = break ((==) '=') str |
63 | thisLen = length key | 63 | thisLen = length key |
64 | padLen = len - thisLen + 1 | 64 | padLen = len - thisLen + 1 |
65 | pad = replicate padLen ' ' | 65 | pad = replicate padLen ' ' |
66 | in | 66 | in |
67 | key ++ pad ++ vals | 67 | key ++ pad ++ vals |
68 | in | 68 | in |
69 | case concat . intersperse tab' . fmap (align longestKeyLen . printProp) $ props of | 69 | case concat . intersperse tab' . fmap (align longestKeyLen . printProp) $ props of |
70 | [] -> [] | 70 | [] -> [] |
71 | xs -> tab ++ xs | 71 | xs -> tab ++ xs |
72 | 72 | ||
73 | 73 | ||
74 | -- | Load the scene graph from the given string. | 74 | -- | Load the scene graph from the given string. |
75 | loadSceneGraph :: String -> Either ParseError SceneGraph | 75 | loadSceneGraph :: String -> Either ParseError SceneGraph |
76 | loadSceneGraph str = parse sceneGraph "(unknown)" $ B.pack str | 76 | loadSceneGraph str = parse sceneGraph "(unknown)" $ B.pack str |
77 | 77 | ||
78 | 78 | ||
79 | -- | Load the scene graph specified by the given file. | 79 | -- | Load the scene graph specified by the given file. |
80 | loadSceneGraphFromFile :: FilePath -> IO (Either ParseError SceneGraph) | 80 | loadSceneGraphFromFile :: FilePath -> IO (Either ParseError SceneGraph) |
81 | loadSceneGraphFromFile = P.parseFromFile sceneGraph | 81 | loadSceneGraphFromFile = P.parseFromFile sceneGraph |
82 | 82 | ||
83 | 83 | ||
84 | -- | Get the node identified by the given string from the given scene graph. | 84 | -- | Get the node identified by the given string from the given scene graph. |
85 | node :: String -> SceneGraph -> Maybe SceneGraph | 85 | node :: String -> SceneGraph -> Maybe SceneGraph |
86 | node str SceneLeaf {} = Nothing | 86 | node str SceneLeaf {} = Nothing |
87 | node str n@(SceneNode nid _ children) | 87 | node str n@(SceneNode nid _ children) |
88 | | str == nid = Just n | 88 | | str == nid = Just n |
89 | | otherwise = case find isJust $ fmap (node str) children of | 89 | | otherwise = case find isJust $ fmap (node str) children of |
90 | Nothing -> Nothing | 90 | Nothing -> Nothing |
91 | Just x -> x | 91 | Just x -> x |
92 | 92 | ||
93 | 93 | ||
94 | sceneGraph :: P.Parser SceneGraph | 94 | sceneGraph :: P.Parser SceneGraph |
95 | sceneGraph = do | 95 | sceneGraph = do |
96 | g <- graph | 96 | g <- graph |
97 | whitespace | 97 | whitespace |
98 | eof | 98 | eof |
99 | return g | 99 | return g |
100 | 100 | ||
101 | 101 | ||
102 | graph :: P.Parser SceneGraph | 102 | graph :: P.Parser SceneGraph |
103 | graph = do | 103 | graph = do |
104 | nid <- name | 104 | nid <- name |
105 | whitespace | 105 | whitespace |
106 | char '{' | 106 | char '{' |
107 | props <- many . try $ whitespace >> property | 107 | props <- many . try $ whitespace >> property |
108 | children <- many . try $ whitespace >> graph | 108 | children <- many . try $ whitespace >> graph |
109 | whitespace | 109 | whitespace |
110 | char '}' | 110 | char '}' |
111 | 111 | ||
112 | return $ case null children of | 112 | return $ case null children of |
113 | True -> SceneLeaf nid props | 113 | True -> SceneLeaf nid props |
114 | False -> SceneNode nid props children | 114 | False -> SceneNode nid props children |
115 | 115 | ||
116 | 116 | ||
117 | property :: P.Parser Property | 117 | property :: P.Parser Property |
118 | property = do | 118 | property = do |
119 | key <- name | 119 | key <- name |
120 | spaces >> char '=' >> spaces | 120 | spaces >> char '=' >> spaces |
121 | vals <- cells name | 121 | vals <- cells name |
122 | return (key, vals) | 122 | return (key, vals) |
123 | 123 | ||
124 | 124 | ||
125 | cells :: P.Parser String -> P.Parser [String] | 125 | cells :: P.Parser String -> P.Parser [String] |
126 | cells p = do | 126 | cells p = do |
127 | val <- p | 127 | val <- p |
128 | vals <- remainingCells p | 128 | vals <- remainingCells p |
129 | return $ val:vals | 129 | return $ val:vals |
130 | 130 | ||
131 | 131 | ||
132 | remainingCells :: P.Parser String -> P.Parser [String] | 132 | remainingCells :: P.Parser String -> P.Parser [String] |
133 | remainingCells p = | 133 | remainingCells p = |
134 | try (whitespace >> char ',' >> whitespace >> cells p) | 134 | try (whitespace >> char ',' >> whitespace >> cells p) |
135 | <|> (return []) | 135 | <|> (return []) |
136 | 136 | ||
137 | 137 | ||
138 | name :: P.Parser String | 138 | name :: P.Parser String |
139 | name = many1 $ choice [oneOf "-/.()?_", alphaNum] | 139 | name = many1 $ choice [oneOf "-/.()?_", alphaNum] |
140 | 140 | ||
141 | 141 | ||
142 | whitespace :: P.Parser () | 142 | whitespace :: P.Parser () |
143 | whitespace = skipMany $ choice [space, newline] | 143 | whitespace = skipMany $ choice [space, newline] |
diff --git a/Spear/Scene/Light.hs b/Spear/Scene/Light.hs index f63b91d..fb4225b 100644 --- a/Spear/Scene/Light.hs +++ b/Spear/Scene/Light.hs | |||
@@ -1,31 +1,31 @@ | |||
1 | module Spear.Scene.Light | 1 | module Spear.Scene.Light |
2 | ( | 2 | ( |
3 | Light(..) | 3 | Light(..) |
4 | ) | 4 | ) |
5 | where | 5 | where |
6 | 6 | ||
7 | 7 | ||
8 | import qualified Spear.Math.Matrix4 as M | 8 | import qualified Spear.Math.Matrix4 as M |
9 | import qualified Spear.Math.Spatial3 as S | 9 | import qualified Spear.Math.Spatial3 as S |
10 | import Spear.Math.Vector | 10 | import Spear.Math.Vector |
11 | 11 | ||
12 | 12 | ||
13 | data Light | 13 | data Light |
14 | = PointLight | 14 | = PointLight |
15 | { ambient :: Vector3 | 15 | { ambient :: Vector3 |
16 | , diffuse :: Vector3 | 16 | , diffuse :: Vector3 |
17 | , specular :: Vector3 | 17 | , specular :: Vector3 |
18 | , transform :: M.Matrix4 | 18 | , transform :: M.Matrix4 |
19 | } | 19 | } |
20 | | DirectionalLight | 20 | | DirectionalLight |
21 | { ambient :: Vector3 | 21 | { ambient :: Vector3 |
22 | , diffuse :: Vector3 | 22 | , diffuse :: Vector3 |
23 | , specular :: Vector3 | 23 | , specular :: Vector3 |
24 | , direction :: Vector3 | 24 | , direction :: Vector3 |
25 | } | 25 | } |
26 | | SpotLight | 26 | | SpotLight |
27 | { ambient :: Vector3 | 27 | { ambient :: Vector3 |
28 | , diffuse :: Vector3 | 28 | , diffuse :: Vector3 |
29 | , specular :: Vector3 | 29 | , specular :: Vector3 |
30 | , transform :: M.Matrix4 | 30 | , transform :: M.Matrix4 |
31 | } | 31 | } |
diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs index b61db94..43ed404 100644 --- a/Spear/Scene/Loader.hs +++ b/Spear/Scene/Loader.hs | |||
@@ -1,428 +1,428 @@ | |||
1 | module Spear.Scene.Loader | 1 | module Spear.Scene.Loader |
2 | ( | 2 | ( |
3 | SceneResources(..) | 3 | SceneResources(..) |
4 | , CreateGameObject | 4 | , CreateGameObject |
5 | , loadScene | 5 | , loadScene |
6 | , validate | 6 | , validate |
7 | , resourceMap | 7 | , resourceMap |
8 | , loadGO | 8 | , loadGO |
9 | , loadObjects | 9 | , loadObjects |
10 | , value | 10 | , value |
11 | , unspecified | 11 | , unspecified |
12 | , mandatory | 12 | , mandatory |
13 | , asString | 13 | , asString |
14 | , asFloat | 14 | , asFloat |
15 | , asVec3 | 15 | , asVec3 |
16 | , asVec4 | 16 | , asVec4 |
17 | ) | 17 | ) |
18 | where | 18 | where |
19 | 19 | ||
20 | import Spear.Assets.Model as Model | 20 | import Spear.Assets.Model as Model |
21 | import Spear.Game | 21 | import Spear.Game |
22 | import qualified Spear.GL as GL | 22 | import qualified Spear.GL as GL |
23 | import Spear.Math.Collision | 23 | import Spear.Math.Collision |
24 | import Spear.Math.Matrix3 as M3 | 24 | import Spear.Math.Matrix3 as M3 |
25 | import Spear.Math.Matrix4 as M4 | 25 | import Spear.Math.Matrix4 as M4 |
26 | import Spear.Math.MatrixUtils (fastNormalMatrix) | 26 | import Spear.Math.MatrixUtils (fastNormalMatrix) |
27 | import Spear.Math.Vector | 27 | import Spear.Math.Vector |
28 | import Spear.Render.AnimatedModel as AM | 28 | import Spear.Render.AnimatedModel as AM |
29 | import Spear.Render.Material | 29 | import Spear.Render.Material |
30 | import Spear.Render.Program | 30 | import Spear.Render.Program |
31 | import Spear.Render.StaticModel as SM | 31 | import Spear.Render.StaticModel as SM |
32 | import Spear.Scene.GameObject as GO | 32 | import Spear.Scene.GameObject as GO |
33 | import Spear.Scene.Graph | 33 | import Spear.Scene.Graph |
34 | import Spear.Scene.Light | 34 | import Spear.Scene.Light |
35 | import Spear.Scene.SceneResources | 35 | import Spear.Scene.SceneResources |
36 | 36 | ||
37 | import Control.Monad.State.Strict | 37 | import Control.Monad.State.Strict |
38 | import Control.Monad.Trans (lift) | 38 | import Control.Monad.Trans (lift) |
39 | import Data.List as L (find) | 39 | import Data.List as L (find) |
40 | import Data.Map as M | 40 | import Data.Map as M |
41 | import qualified Data.StateVar as SV (get) | 41 | import qualified Data.StateVar as SV (get) |
42 | import Text.Printf (printf) | 42 | import Text.Printf (printf) |
43 | 43 | ||
44 | type Loader = Game SceneResources | 44 | type Loader = Game SceneResources |
45 | 45 | ||
46 | -- | Load the scene specified by the given file. | 46 | -- | Load the scene specified by the given file. |
47 | loadScene :: FilePath -> Game s (SceneResources, SceneGraph) | 47 | loadScene :: FilePath -> Game s (SceneResources, SceneGraph) |
48 | loadScene file = do | 48 | loadScene file = do |
49 | result <- gameIO $ loadSceneGraphFromFile file | 49 | result <- gameIO $ loadSceneGraphFromFile file |
50 | case result of | 50 | case result of |
51 | Left err -> gameError $ show err | 51 | Left err -> gameError $ show err |
52 | Right g -> case validate g of | 52 | Right g -> case validate g of |
53 | Nothing -> do | 53 | Nothing -> do |
54 | sceneRes <- resourceMap g | 54 | sceneRes <- resourceMap g |
55 | return (sceneRes, g) | 55 | return (sceneRes, g) |
56 | Just err -> gameError err | 56 | Just err -> gameError err |
57 | 57 | ||
58 | -- | Validate the given SceneGraph. | 58 | -- | Validate the given SceneGraph. |
59 | validate :: SceneGraph -> Maybe String | 59 | validate :: SceneGraph -> Maybe String |
60 | validate _ = Nothing | 60 | validate _ = Nothing |
61 | 61 | ||
62 | -- | Load the scene described by the given 'SceneGraph'. | 62 | -- | Load the scene described by the given 'SceneGraph'. |
63 | resourceMap :: SceneGraph -> Game s SceneResources | 63 | resourceMap :: SceneGraph -> Game s SceneResources |
64 | resourceMap g = execSubGame (resourceMap' g) emptySceneResources | 64 | resourceMap g = execSubGame (resourceMap' g) emptySceneResources |
65 | 65 | ||
66 | resourceMap' :: SceneGraph -> Loader () | 66 | resourceMap' :: SceneGraph -> Loader () |
67 | resourceMap' node@(SceneLeaf nid props) = do | 67 | resourceMap' node@(SceneLeaf nid props) = do |
68 | case nid of | 68 | case nid of |
69 | "shader-program" -> newShaderProgram node | 69 | "shader-program" -> newShaderProgram node |
70 | "model" -> newModel node | 70 | "model" -> newModel node |
71 | "light" -> newLight node | 71 | "light" -> newLight node |
72 | x -> return () | 72 | x -> return () |
73 | 73 | ||
74 | resourceMap' node@(SceneNode nid props children) = do | 74 | resourceMap' node@(SceneNode nid props children) = do |
75 | mapM_ resourceMap' children | 75 | mapM_ resourceMap' children |
76 | 76 | ||
77 | -- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it. | 77 | -- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it. |
78 | loadResource :: String -- ^ Resource name. | 78 | loadResource :: String -- ^ Resource name. |
79 | -> (SceneResources -> Map String a) -- ^ Map getter. | 79 | -> (SceneResources -> Map String a) -- ^ Map getter. |
80 | -> (String -> a -> Loader ()) -- ^ Function to modify resources. | 80 | -> (String -> a -> Loader ()) -- ^ Function to modify resources. |
81 | -> Loader a -- ^ Resource loader. | 81 | -> Loader a -- ^ Resource loader. |
82 | -> Loader a | 82 | -> Loader a |
83 | loadResource key field modifyResources load = do | 83 | loadResource key field modifyResources load = do |
84 | sceneData <- get | 84 | sceneData <- get |
85 | case M.lookup key $ field sceneData of | 85 | case M.lookup key $ field sceneData of |
86 | Just val -> return val | 86 | Just val -> return val |
87 | Nothing -> do | 87 | Nothing -> do |
88 | gameIO $ printf "Loading %s..." key | 88 | gameIO $ printf "Loading %s..." key |
89 | resource <- load | 89 | resource <- load |
90 | gameIO $ printf "done\n" | 90 | gameIO $ printf "done\n" |
91 | modifyResources key resource | 91 | modifyResources key resource |
92 | return resource | 92 | return resource |
93 | 93 | ||
94 | addShader name shader = modify $ \sceneData -> | 94 | addShader name shader = modify $ \sceneData -> |
95 | sceneData { shaders = M.insert name shader $ shaders sceneData } | 95 | sceneData { shaders = M.insert name shader $ shaders sceneData } |
96 | 96 | ||
97 | addCustomProgram name prog = modify $ \sceneData -> | 97 | addCustomProgram name prog = modify $ \sceneData -> |
98 | sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } | 98 | sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } |
99 | 99 | ||
100 | addStaticProgram name prog = modify $ \sceneData -> | 100 | addStaticProgram name prog = modify $ \sceneData -> |
101 | sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } | 101 | sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } |
102 | 102 | ||
103 | addAnimatedProgram name prog = modify $ \sceneData -> | 103 | addAnimatedProgram name prog = modify $ \sceneData -> |
104 | sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } | 104 | sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } |
105 | 105 | ||
106 | addTexture name tex = modify $ \sceneData -> | 106 | addTexture name tex = modify $ \sceneData -> |
107 | sceneData { textures = M.insert name tex $ textures sceneData } | 107 | sceneData { textures = M.insert name tex $ textures sceneData } |
108 | 108 | ||
109 | addStaticModel name model = modify $ | 109 | addStaticModel name model = modify $ |
110 | \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData } | 110 | \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData } |
111 | 111 | ||
112 | addAnimatedModel name model = modify $ | 112 | addAnimatedModel name model = modify $ |
113 | \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData } | 113 | \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData } |
114 | 114 | ||
115 | -- Get the given resource from the data pool. | 115 | -- Get the given resource from the data pool. |
116 | getResource :: (SceneResources -> Map String a) -> String -> Loader a | 116 | getResource :: (SceneResources -> Map String a) -> String -> Loader a |
117 | getResource field key = do | 117 | getResource field key = do |
118 | sceneData <- get | 118 | sceneData <- get |
119 | case M.lookup key $ field sceneData of | 119 | case M.lookup key $ field sceneData of |
120 | Just val -> return val | 120 | Just val -> return val |
121 | Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key | 121 | Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key |
122 | 122 | ||
123 | ---------------------- | 123 | ---------------------- |
124 | -- Resource Loading -- | 124 | -- Resource Loading -- |
125 | ---------------------- | 125 | ---------------------- |
126 | 126 | ||
127 | newModel :: SceneGraph -> Loader () | 127 | newModel :: SceneGraph -> Loader () |
128 | newModel (SceneLeaf _ props) = do | 128 | newModel (SceneLeaf _ props) = do |
129 | name <- asString $ mandatory' "name" props | 129 | name <- asString $ mandatory' "name" props |
130 | file <- asString $ mandatory' "file" props | 130 | file <- asString $ mandatory' "file" props |
131 | tex <- asString $ mandatory' "texture" props | 131 | tex <- asString $ mandatory' "texture" props |
132 | prog <- asString $ mandatory' "shader-program" props | 132 | prog <- asString $ mandatory' "shader-program" props |
133 | ke <- asVec4 $ mandatory' "ke" props | 133 | ke <- asVec4 $ mandatory' "ke" props |
134 | ka <- asVec4 $ mandatory' "ka" props | 134 | ka <- asVec4 $ mandatory' "ka" props |
135 | kd <- asVec4 $ mandatory' "kd" props | 135 | kd <- asVec4 $ mandatory' "kd" props |
136 | ks <- asVec4 $ mandatory' "ks" props | 136 | ks <- asVec4 $ mandatory' "ks" props |
137 | shi <- asFloat $ mandatory' "shi" props | 137 | shi <- asFloat $ mandatory' "shi" props |
138 | 138 | ||
139 | let rotation = asRotation $ value "rotation" props | 139 | let rotation = asRotation $ value "rotation" props |
140 | scale = asVec3 $ value "scale" props | 140 | scale = asVec3 $ value "scale" props |
141 | 141 | ||
142 | gameIO $ printf "Loading model %s..." name | 142 | gameIO $ printf "Loading model %s..." name |
143 | model <- loadModel' file rotation scale | 143 | model <- loadModel' file rotation scale |
144 | gameIO . putStrLn $ "done" | 144 | gameIO . putStrLn $ "done" |
145 | texture <- loadTexture tex | 145 | texture <- loadTexture tex |
146 | sceneRes <- get | 146 | sceneRes <- get |
147 | 147 | ||
148 | let material = Material ke ka kd ks shi | 148 | let material = Material ke ka kd ks shi |
149 | 149 | ||
150 | case animated model of | 150 | case animated model of |
151 | False -> | 151 | False -> |
152 | case M.lookup prog $ staticPrograms sceneRes of | 152 | case M.lookup prog $ staticPrograms sceneRes of |
153 | Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return () | 153 | Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return () |
154 | Just p -> | 154 | Just p -> |
155 | let StaticProgram _ channels _ = p | 155 | let StaticProgram _ channels _ = p |
156 | in do | 156 | in do |
157 | model' <- staticModelResource channels material texture model | 157 | model' <- staticModelResource channels material texture model |
158 | loadResource name staticModels addStaticModel (return model') | 158 | loadResource name staticModels addStaticModel (return model') |
159 | return () | 159 | return () |
160 | True -> | 160 | True -> |
161 | case M.lookup prog $ animatedPrograms sceneRes of | 161 | case M.lookup prog $ animatedPrograms sceneRes of |
162 | Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return () | 162 | Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return () |
163 | Just p -> | 163 | Just p -> |
164 | let AnimatedProgram _ channels _ = p | 164 | let AnimatedProgram _ channels _ = p |
165 | in do | 165 | in do |
166 | model' <- animatedModelResource channels material texture model | 166 | model' <- animatedModelResource channels material texture model |
167 | loadResource name animatedModels addAnimatedModel (return model') | 167 | loadResource name animatedModels addAnimatedModel (return model') |
168 | return () | 168 | return () |
169 | 169 | ||
170 | loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model | 170 | loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model |
171 | loadModel' file rotation scale = do | 171 | loadModel' file rotation scale = do |
172 | let transform = | 172 | let transform = |
173 | (case rotation of | 173 | (case rotation of |
174 | Nothing -> Prelude.id | 174 | Nothing -> Prelude.id |
175 | Just rot -> rotateModel rot) . | 175 | Just rot -> rotateModel rot) . |
176 | 176 | ||
177 | (case scale of | 177 | (case scale of |
178 | Nothing -> Prelude.id | 178 | Nothing -> Prelude.id |
179 | Just s -> flip Model.transformVerts $ | 179 | Just s -> flip Model.transformVerts $ |
180 | \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')) | 180 | \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')) |
181 | 181 | ||
182 | (fmap transform $ Model.loadModel file) >>= gameIO . toGround | 182 | (fmap transform $ Model.loadModel file) >>= gameIO . toGround |
183 | 183 | ||
184 | rotateModel :: Rotation -> Model -> Model | 184 | rotateModel :: Rotation -> Model -> Model |
185 | rotateModel (Rotation ax ay az order) model = | 185 | rotateModel (Rotation ax ay az order) model = |
186 | let mat = case order of | 186 | let mat = case order of |
187 | XYZ -> rotZ az * rotY ay * rotX ax | 187 | XYZ -> rotZ az * rotY ay * rotX ax |
188 | XZY -> rotY ay * rotZ az * rotX ax | 188 | XZY -> rotY ay * rotZ az * rotX ax |
189 | YXZ -> rotZ az * rotX ax * rotY ay | 189 | YXZ -> rotZ az * rotX ax * rotY ay |
190 | YZX -> rotX ax * rotZ az * rotY ay | 190 | YZX -> rotX ax * rotZ az * rotY ay |
191 | ZXY -> rotY ay * rotX ax * rotZ az | 191 | ZXY -> rotY ay * rotX ax * rotZ az |
192 | ZYX -> rotX ax * rotY ay * rotZ az | 192 | ZYX -> rotX ax * rotY ay * rotZ az |
193 | normalMat = fastNormalMatrix mat | 193 | normalMat = fastNormalMatrix mat |
194 | 194 | ||
195 | vTransform (Vec3 x' y' z') = | 195 | vTransform (Vec3 x' y' z') = |
196 | let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) | 196 | let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) |
197 | 197 | ||
198 | nTransform (Vec3 x' y' z') = | 198 | nTransform (Vec3 x' y' z') = |
199 | let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) | 199 | let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) |
200 | in | 200 | in |
201 | flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model | 201 | flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model |
202 | 202 | ||
203 | loadTexture :: FilePath -> Loader GL.Texture | 203 | loadTexture :: FilePath -> Loader GL.Texture |
204 | loadTexture file = | 204 | loadTexture file = |
205 | loadResource file textures addTexture $ | 205 | loadResource file textures addTexture $ |
206 | GL.loadTextureImage file GL.gl_LINEAR GL.gl_LINEAR | 206 | GL.loadTextureImage file GL.gl_LINEAR GL.gl_LINEAR |
207 | 207 | ||
208 | newShaderProgram :: SceneGraph -> Loader () | 208 | newShaderProgram :: SceneGraph -> Loader () |
209 | newShaderProgram (SceneLeaf _ props) = do | 209 | newShaderProgram (SceneLeaf _ props) = do |
210 | (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props | 210 | (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props |
211 | (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props | 211 | (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props |
212 | name <- asString $ mandatory' "name" props | 212 | name <- asString $ mandatory' "name" props |
213 | stype <- asString $ mandatory' "type" props | 213 | stype <- asString $ mandatory' "type" props |
214 | prog <- GL.newProgram [vertShader, fragShader] | 214 | prog <- GL.newProgram [vertShader, fragShader] |
215 | 215 | ||
216 | let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name | 216 | let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name |
217 | 217 | ||
218 | case stype of | 218 | case stype of |
219 | "static" -> do | 219 | "static" -> do |
220 | ambient <- asString $ mandatory' "ambient" props | 220 | ambient <- asString $ mandatory' "ambient" props |
221 | diffuse <- asString $ mandatory' "diffuse" props | 221 | diffuse <- asString $ mandatory' "diffuse" props |
222 | specular <- asString $ mandatory' "specular" props | 222 | specular <- asString $ mandatory' "specular" props |
223 | shininess <- asString $ mandatory' "shininess" props | 223 | shininess <- asString $ mandatory' "shininess" props |
224 | texture <- asString $ mandatory' "texture" props | 224 | texture <- asString $ mandatory' "texture" props |
225 | modelview <- asString $ mandatory' "modelview" props | 225 | modelview <- asString $ mandatory' "modelview" props |
226 | normalmat <- asString $ mandatory' "normalmat" props | 226 | normalmat <- asString $ mandatory' "normalmat" props |
227 | projection <- asString $ mandatory' "projection" props | 227 | projection <- asString $ mandatory' "projection" props |
228 | 228 | ||
229 | ka <- getUniformLoc ambient | 229 | ka <- getUniformLoc ambient |
230 | kd <- getUniformLoc diffuse | 230 | kd <- getUniformLoc diffuse |
231 | ks <- getUniformLoc specular | 231 | ks <- getUniformLoc specular |
232 | shi <- getUniformLoc shininess | 232 | shi <- getUniformLoc shininess |
233 | tex <- getUniformLoc texture | 233 | tex <- getUniformLoc texture |
234 | mview <- getUniformLoc modelview | 234 | mview <- getUniformLoc modelview |
235 | nmat <- getUniformLoc normalmat | 235 | nmat <- getUniformLoc normalmat |
236 | proj <- getUniformLoc projection | 236 | proj <- getUniformLoc projection |
237 | 237 | ||
238 | vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props | 238 | vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props |
239 | normChan <- fmap read $ asString $ mandatory' "normal-channel" props | 239 | normChan <- fmap read $ asString $ mandatory' "normal-channel" props |
240 | texChan <- fmap read $ asString $ mandatory' "texture-channel" props | 240 | texChan <- fmap read $ asString $ mandatory' "texture-channel" props |
241 | 241 | ||
242 | let channels = StaticProgramChannels vertChan normChan texChan | 242 | let channels = StaticProgramChannels vertChan normChan texChan |
243 | uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj | 243 | uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj |
244 | 244 | ||
245 | loadResource name staticPrograms addStaticProgram $ | 245 | loadResource name staticPrograms addStaticProgram $ |
246 | return $ StaticProgram prog channels uniforms | 246 | return $ StaticProgram prog channels uniforms |
247 | return () | 247 | return () |
248 | 248 | ||
249 | "animated" -> do | 249 | "animated" -> do |
250 | ambient <- asString $ mandatory' "ambient" props | 250 | ambient <- asString $ mandatory' "ambient" props |
251 | diffuse <- asString $ mandatory' "diffuse" props | 251 | diffuse <- asString $ mandatory' "diffuse" props |
252 | specular <- asString $ mandatory' "specular" props | 252 | specular <- asString $ mandatory' "specular" props |
253 | shininess <- asString $ mandatory' "shininess" props | 253 | shininess <- asString $ mandatory' "shininess" props |
254 | texture <- asString $ mandatory' "texture" props | 254 | texture <- asString $ mandatory' "texture" props |
255 | modelview <- asString $ mandatory' "modelview" props | 255 | modelview <- asString $ mandatory' "modelview" props |
256 | normalmat <- asString $ mandatory' "normalmat" props | 256 | normalmat <- asString $ mandatory' "normalmat" props |
257 | projection <- asString $ mandatory' "projection" props | 257 | projection <- asString $ mandatory' "projection" props |
258 | 258 | ||
259 | ka <- getUniformLoc ambient | 259 | ka <- getUniformLoc ambient |
260 | kd <- getUniformLoc diffuse | 260 | kd <- getUniformLoc diffuse |
261 | ks <- getUniformLoc specular | 261 | ks <- getUniformLoc specular |
262 | shi <- getUniformLoc shininess | 262 | shi <- getUniformLoc shininess |
263 | tex <- getUniformLoc texture | 263 | tex <- getUniformLoc texture |
264 | mview <- getUniformLoc modelview | 264 | mview <- getUniformLoc modelview |
265 | nmat <- getUniformLoc normalmat | 265 | nmat <- getUniformLoc normalmat |
266 | proj <- getUniformLoc projection | 266 | proj <- getUniformLoc projection |
267 | 267 | ||
268 | vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props | 268 | vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props |
269 | vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props | 269 | vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props |
270 | normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props | 270 | normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props |
271 | normChan2 <- fmap read $ asString $ mandatory' "normal-channel2" props | 271 | normChan2 <- fmap read $ asString $ mandatory' "normal-channel2" props |
272 | texChan <- fmap read $ asString $ mandatory' "texture-channel" props | 272 | texChan <- fmap read $ asString $ mandatory' "texture-channel" props |
273 | fp <- asString $ mandatory' "fp" props | 273 | fp <- asString $ mandatory' "fp" props |
274 | p <- getUniformLoc fp | 274 | p <- getUniformLoc fp |
275 | 275 | ||
276 | let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan | 276 | let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan |
277 | uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj | 277 | uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj |
278 | 278 | ||
279 | loadResource name animatedPrograms addAnimatedProgram $ | 279 | loadResource name animatedPrograms addAnimatedProgram $ |
280 | return $ AnimatedProgram prog channels uniforms | 280 | return $ AnimatedProgram prog channels uniforms |
281 | return () | 281 | return () |
282 | 282 | ||
283 | _ -> do | 283 | _ -> do |
284 | loadResource name customPrograms addCustomProgram $ return prog | 284 | loadResource name customPrograms addCustomProgram $ return prog |
285 | return () | 285 | return () |
286 | 286 | ||
287 | loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) | 287 | loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) |
288 | loadShader _ [] = gameError $ "Loader::vertexShader: empty list" | 288 | loadShader _ [] = gameError $ "Loader::vertexShader: empty list" |
289 | loadShader shaderType ((stype, file):xs) = | 289 | loadShader shaderType ((stype, file):xs) = |
290 | if shaderType == GL.VertexShader && stype == "vertex-shader" || | 290 | if shaderType == GL.VertexShader && stype == "vertex-shader" || |
291 | shaderType == GL.FragmentShader && stype == "fragment-shader" | 291 | shaderType == GL.FragmentShader && stype == "fragment-shader" |
292 | then let f = concat file | 292 | then let f = concat file |
293 | in loadShader' f shaderType >>= \shader -> return (f, shader) | 293 | in loadShader' f shaderType >>= \shader -> return (f, shader) |
294 | else Spear.Scene.Loader.loadShader shaderType xs | 294 | else Spear.Scene.Loader.loadShader shaderType xs |
295 | 295 | ||
296 | loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader | 296 | loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader |
297 | loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file | 297 | loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file |
298 | 298 | ||
299 | newLight :: SceneGraph -> Loader () | 299 | newLight :: SceneGraph -> Loader () |
300 | newLight _ = return () | 300 | newLight _ = return () |
301 | 301 | ||
302 | -------------------- | 302 | -------------------- |
303 | -- Object Loading -- | 303 | -- Object Loading -- |
304 | -------------------- | 304 | -------------------- |
305 | 305 | ||
306 | loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject | 306 | loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject |
307 | loadGO style sceneRes props transf = do | 307 | loadGO style sceneRes props transf = do |
308 | modelName <- asString . mandatory "model" $ props | 308 | modelName <- asString . mandatory "model" $ props |
309 | axis <- asVec3 . mandatory "axis" $ props | 309 | axis <- asVec3 . mandatory "axis" $ props |
310 | let animSpeed = asFloat . value "animation-speed" $ props | 310 | let animSpeed = asFloat . value "animation-speed" $ props |
311 | go <- case getAnimatedModel sceneRes modelName of | 311 | go <- case getAnimatedModel sceneRes modelName of |
312 | Just model -> | 312 | Just model -> |
313 | return $ goNew style (Right model) [] transf axis | 313 | return $ goNew style (Right model) [] transf axis |
314 | Nothing -> | 314 | Nothing -> |
315 | case getStaticModel sceneRes modelName of | 315 | case getStaticModel sceneRes modelName of |
316 | Just model -> | 316 | Just model -> |
317 | return $ goNew style (Left model) [] transf axis | 317 | return $ goNew style (Left model) [] transf axis |
318 | Nothing -> | 318 | Nothing -> |
319 | gameError $ "model " ++ modelName ++ " not found" | 319 | gameError $ "model " ++ modelName ++ " not found" |
320 | return $ case animSpeed of | 320 | return $ case animSpeed of |
321 | Nothing -> go | 321 | Nothing -> go |
322 | Just s -> GO.setAnimationSpeed s go | 322 | Just s -> GO.setAnimationSpeed s go |
323 | 323 | ||
324 | type CreateGameObject m a | 324 | type CreateGameObject m a |
325 | = String -- ^ The object's name. | 325 | = String -- ^ The object's name. |
326 | -> SceneResources | 326 | -> SceneResources |
327 | -> [Property] | 327 | -> [Property] |
328 | -> Matrix3 -- ^ The object's transform. | 328 | -> Matrix3 -- ^ The object's transform. |
329 | -> m a | 329 | -> m a |
330 | 330 | ||
331 | -- | Load objects from the given 'SceneGraph'. | 331 | -- | Load objects from the given 'SceneGraph'. |
332 | loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] | 332 | loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] |
333 | loadObjects newGO sceneRes g = | 333 | loadObjects newGO sceneRes g = |
334 | case node "layout" g of | 334 | case node "layout" g of |
335 | Nothing -> return [] | 335 | Nothing -> return [] |
336 | Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n | 336 | Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n |
337 | 337 | ||
338 | -- to-do: use a strict accumulator and make loadObjects tail recursive. | 338 | -- to-do: use a strict accumulator and make loadObjects tail recursive. |
339 | newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] | 339 | newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] |
340 | newObject newGO sceneRes (SceneNode nid props children) = | 340 | newObject newGO sceneRes (SceneNode nid props children) = |
341 | let o = newObject' newGO sceneRes nid props | 341 | let o = newObject' newGO sceneRes nid props |
342 | in o : (concat $ fmap (newObject newGO sceneRes) children) | 342 | in o : (concat $ fmap (newObject newGO sceneRes) children) |
343 | 343 | ||
344 | newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] | 344 | newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] |
345 | 345 | ||
346 | newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a | 346 | newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a |
347 | newObject' newGO sceneRes nid props = do | 347 | newObject' newGO sceneRes nid props = do |
348 | -- Optional properties. | 348 | -- Optional properties. |
349 | let goType = (asString $ value "type" props) `unspecified` "unknown" | 349 | let goType = (asString $ value "type" props) `unspecified` "unknown" |
350 | position = (asVec2 $ value "position" props) `unspecified` vec2 0 0 | 350 | position = (asVec2 $ value "position" props) `unspecified` vec2 0 0 |
351 | rotation = (asVec2 $ value "rotation" 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 | 352 | right' = (asVec2 $ value "right" props) `unspecified` vec2 1 0 |
353 | up' = asVec2 $ value "up" props | 353 | up' = asVec2 $ value "up" props |
354 | scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1 | 354 | scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1 |
355 | 355 | ||
356 | -- Compute the object's vectors if an up/forward vector has been specified. | 356 | -- Compute the object's vectors if an up/forward vector has been specified. |
357 | let (right, up) = vectors up' | 357 | let (right, up) = vectors up' |
358 | 358 | ||
359 | newGO goType sceneRes props (M3.transform right up position) | 359 | newGO goType sceneRes props (M3.transform right up position) |
360 | 360 | ||
361 | vectors :: Maybe Vector2 -> (Vector2, Vector2) | 361 | vectors :: Maybe Vector2 -> (Vector2, Vector2) |
362 | vectors up = case up of | 362 | vectors up = case up of |
363 | Nothing -> (unitx2, unity2) | 363 | Nothing -> (unitx2, unity2) |
364 | Just u -> (perp u, u) | 364 | Just u -> (perp u, u) |
365 | 365 | ||
366 | ---------------------- | 366 | ---------------------- |
367 | -- Helper functions -- | 367 | -- Helper functions -- |
368 | ---------------------- | 368 | ---------------------- |
369 | 369 | ||
370 | -- Get the value of the given key. | 370 | -- Get the value of the given key. |
371 | value :: String -> [Property] -> Maybe [String] | 371 | value :: String -> [Property] -> Maybe [String] |
372 | value name props = case L.find ((==) name . fst) props of | 372 | value name props = case L.find ((==) name . fst) props of |
373 | Nothing -> Nothing | 373 | Nothing -> Nothing |
374 | Just prop -> Just . snd $ prop | 374 | Just prop -> Just . snd $ prop |
375 | 375 | ||
376 | unspecified :: Maybe a -> a -> a | 376 | unspecified :: Maybe a -> a -> a |
377 | unspecified (Just x) _ = x | 377 | unspecified (Just x) _ = x |
378 | unspecified Nothing x = x | 378 | unspecified Nothing x = x |
379 | 379 | ||
380 | mandatory :: String -> [Property] -> Game s [String] | 380 | mandatory :: String -> [Property] -> Game s [String] |
381 | mandatory name props = case value name props of | 381 | mandatory name props = case value name props of |
382 | Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name | 382 | Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name |
383 | Just x -> return x | 383 | Just x -> return x |
384 | 384 | ||
385 | mandatory' :: String -> [Property] -> Loader [String] | 385 | mandatory' :: String -> [Property] -> Loader [String] |
386 | mandatory' name props = mandatory name props | 386 | mandatory' name props = mandatory name props |
387 | 387 | ||
388 | asString :: Functor f => f [String] -> f String | 388 | asString :: Functor f => f [String] -> f String |
389 | asString = fmap concat | 389 | asString = fmap concat |
390 | 390 | ||
391 | asFloat :: Functor f => f [String] -> f Float | 391 | asFloat :: Functor f => f [String] -> f Float |
392 | asFloat = fmap (read . concat) | 392 | asFloat = fmap (read . concat) |
393 | 393 | ||
394 | asVec2 :: Functor f => f [String] -> f Vector2 | 394 | asVec2 :: Functor f => f [String] -> f Vector2 |
395 | asVec2 val = fmap toVec2 val | 395 | asVec2 val = fmap toVec2 val |
396 | where toVec2 (x:y:_) = vec2 (read x) (read y) | 396 | where toVec2 (x:y:_) = vec2 (read x) (read y) |
397 | toVec2 (x:[]) = let x' = read x in vec2 x' x' | 397 | toVec2 (x:[]) = let x' = read x in vec2 x' x' |
398 | 398 | ||
399 | asVec3 :: Functor f => f [String] -> f Vector3 | 399 | asVec3 :: Functor f => f [String] -> f Vector3 |
400 | asVec3 val = fmap toVec3 val | 400 | asVec3 val = fmap toVec3 val |
401 | where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z) | 401 | where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z) |
402 | toVec3 (x:[]) = let x' = read x in vec3 x' x' x' | 402 | toVec3 (x:[]) = let x' = read x in vec3 x' x' x' |
403 | 403 | ||
404 | asVec4 :: Functor f => f [String] -> f Vector4 | 404 | asVec4 :: Functor f => f [String] -> f Vector4 |
405 | asVec4 val = fmap toVec4 val | 405 | asVec4 val = fmap toVec4 val |
406 | where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w) | 406 | where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w) |
407 | toVec4 (x:[]) = let x' = read x in vec4 x' x' x' x' | 407 | toVec4 (x:[]) = let x' = read x in vec4 x' x' x' x' |
408 | 408 | ||
409 | asRotation :: Functor f => f [String] -> f Rotation | 409 | asRotation :: Functor f => f [String] -> f Rotation |
410 | asRotation val = fmap parseRotation val | 410 | asRotation val = fmap parseRotation val |
411 | where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order) | 411 | where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order) |
412 | 412 | ||
413 | data Rotation = Rotation | 413 | data Rotation = Rotation |
414 | { ax :: Float | 414 | { ax :: Float |
415 | , ay :: Float | 415 | , ay :: Float |
416 | , az :: Float | 416 | , az :: Float |
417 | , order :: RotationOrder | 417 | , order :: RotationOrder |
418 | } | 418 | } |
419 | 419 | ||
420 | data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq | 420 | data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq |
421 | 421 | ||
422 | readOrder :: String -> RotationOrder | 422 | readOrder :: String -> RotationOrder |
423 | readOrder "xyz" = XYZ | 423 | readOrder "xyz" = XYZ |
424 | readOrder "xzy" = XZY | 424 | readOrder "xzy" = XZY |
425 | readOrder "yxz" = YXZ | 425 | readOrder "yxz" = YXZ |
426 | readOrder "yzx" = YZX | 426 | readOrder "yzx" = YZX |
427 | readOrder "zxy" = ZXY | 427 | readOrder "zxy" = ZXY |
428 | readOrder "zyx" = ZYX | 428 | readOrder "zyx" = ZYX |
diff --git a/Spear/Scene/SceneResources.hs b/Spear/Scene/SceneResources.hs index d75db56..3c7d204 100644 --- a/Spear/Scene/SceneResources.hs +++ b/Spear/Scene/SceneResources.hs | |||
@@ -1,72 +1,72 @@ | |||
1 | module Spear.Scene.SceneResources | 1 | module Spear.Scene.SceneResources |
2 | ( | 2 | ( |
3 | -- * Data types | 3 | -- * Data types |
4 | SceneResources(..) | 4 | SceneResources(..) |
5 | , StaticProgram(..) | 5 | , StaticProgram(..) |
6 | , AnimatedProgram(..) | 6 | , AnimatedProgram(..) |
7 | -- * Construction | 7 | -- * Construction |
8 | , emptySceneResources | 8 | , emptySceneResources |
9 | -- * Accessors | 9 | -- * Accessors |
10 | , getShader | 10 | , getShader |
11 | , getCustomProgram | 11 | , getCustomProgram |
12 | , getStaticProgram | 12 | , getStaticProgram |
13 | , getAnimatedProgram | 13 | , getAnimatedProgram |
14 | , getTexture | 14 | , getTexture |
15 | , getStaticModel | 15 | , getStaticModel |
16 | , getAnimatedModel | 16 | , getAnimatedModel |
17 | ) | 17 | ) |
18 | where | 18 | where |
19 | 19 | ||
20 | import Spear.Assets.Model as Model | 20 | import Spear.Assets.Model as Model |
21 | import Spear.GL as GL | 21 | import Spear.GL as GL |
22 | import Spear.Math.Vector | 22 | import Spear.Math.Vector |
23 | import Spear.Render.AnimatedModel | 23 | 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 | 27 | import Spear.Scene.Light |
28 | 28 | ||
29 | import Data.Map as M | 29 | import Data.Map as M |
30 | 30 | ||
31 | data SceneResources = SceneResources | 31 | data SceneResources = SceneResources |
32 | { shaders :: Map String GLSLShader | 32 | { shaders :: Map String GLSLShader |
33 | , customPrograms :: Map String GLSLProgram | 33 | , customPrograms :: Map String GLSLProgram |
34 | , staticPrograms :: Map String StaticProgram | 34 | , staticPrograms :: Map String StaticProgram |
35 | , animatedPrograms :: Map String AnimatedProgram | 35 | , animatedPrograms :: Map String AnimatedProgram |
36 | , textures :: Map String Texture | 36 | , textures :: Map String Texture |
37 | , staticModels :: Map String StaticModelResource | 37 | , staticModels :: Map String StaticModelResource |
38 | , animatedModels :: Map String AnimatedModelResource | 38 | , animatedModels :: Map String AnimatedModelResource |
39 | , lights :: [Light] | 39 | , lights :: [Light] |
40 | } | 40 | } |
41 | 41 | ||
42 | -- | Build an empty instance of 'SceneResources'. | 42 | -- | Build an empty instance of 'SceneResources'. |
43 | emptySceneResources = | 43 | emptySceneResources = |
44 | SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty [] | 44 | SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty [] |
45 | 45 | ||
46 | -- | Get the shader specified by the given string. | 46 | -- | Get the shader specified by the given string. |
47 | getShader :: SceneResources -> String -> Maybe GLSLShader | 47 | getShader :: SceneResources -> String -> Maybe GLSLShader |
48 | getShader res key = M.lookup key $ shaders res | 48 | getShader res key = M.lookup key $ shaders res |
49 | 49 | ||
50 | -- | Get the custom program specified by the given string. | 50 | -- | Get the custom program specified by the given string. |
51 | getCustomProgram :: SceneResources -> String -> Maybe GLSLProgram | 51 | getCustomProgram :: SceneResources -> String -> Maybe GLSLProgram |
52 | getCustomProgram res key = M.lookup key $ customPrograms res | 52 | getCustomProgram res key = M.lookup key $ customPrograms res |
53 | 53 | ||
54 | -- | Get the static program specified by the given string. | 54 | -- | Get the static program specified by the given string. |
55 | getStaticProgram :: SceneResources -> String -> Maybe StaticProgram | 55 | getStaticProgram :: SceneResources -> String -> Maybe StaticProgram |
56 | getStaticProgram res key = M.lookup key $ staticPrograms res | 56 | getStaticProgram res key = M.lookup key $ staticPrograms res |
57 | 57 | ||
58 | -- | Get the animated program specified by the given string. | 58 | -- | Get the animated program specified by the given string. |
59 | getAnimatedProgram :: SceneResources -> String -> Maybe AnimatedProgram | 59 | getAnimatedProgram :: SceneResources -> String -> Maybe AnimatedProgram |
60 | getAnimatedProgram res key = M.lookup key $ animatedPrograms res | 60 | getAnimatedProgram res key = M.lookup key $ animatedPrograms res |
61 | 61 | ||
62 | -- | Get the texture specified by the given string. | 62 | -- | Get the texture specified by the given string. |
63 | getTexture :: SceneResources -> String -> Maybe Texture | 63 | getTexture :: SceneResources -> String -> Maybe Texture |
64 | getTexture res key = M.lookup key $ textures res | 64 | getTexture res key = M.lookup key $ textures res |
65 | 65 | ||
66 | -- | Get the static model resource specified by the given string. | 66 | -- | Get the static model resource specified by the given string. |
67 | getStaticModel :: SceneResources -> String -> Maybe StaticModelResource | 67 | getStaticModel :: SceneResources -> String -> Maybe StaticModelResource |
68 | getStaticModel res key = M.lookup key $ staticModels res | 68 | getStaticModel res key = M.lookup key $ staticModels res |
69 | 69 | ||
70 | -- | Get the animated model resource specified by the given string. | 70 | -- | Get the animated model resource specified by the given string. |
71 | getAnimatedModel :: SceneResources -> String -> Maybe AnimatedModelResource | 71 | getAnimatedModel :: SceneResources -> String -> Maybe AnimatedModelResource |
72 | getAnimatedModel res key = M.lookup key $ animatedModels res | 72 | getAnimatedModel res key = M.lookup key $ animatedModels res |
diff --git a/Spear/Sys/Store.hs b/Spear/Sys/Store.hs index 3c1e720..9752707 100644 --- a/Spear/Sys/Store.hs +++ b/Spear/Sys/Store.hs | |||
@@ -1,195 +1,195 @@ | |||
1 | module Spear.Sys.Store | 1 | module Spear.Sys.Store |
2 | ( | 2 | ( |
3 | Store | 3 | Store |
4 | , Index | 4 | , Index |
5 | , emptyStore | 5 | , emptyStore |
6 | , store | 6 | , store |
7 | , storel | 7 | , storel |
8 | , storeFree | 8 | , storeFree |
9 | , storeFreel | 9 | , storeFreel |
10 | , element | 10 | , element |
11 | , setElement | 11 | , setElement |
12 | , withElement | 12 | , withElement |
13 | ) | 13 | ) |
14 | where | 14 | where |
15 | 15 | ||
16 | 16 | ||
17 | import Data.List as L (find) | 17 | import Data.List as L (find) |
18 | import Data.Maybe (isJust, isNothing) | 18 | import Data.Maybe (isJust, isNothing) |
19 | import Data.Vector as V | 19 | import Data.Vector as V |
20 | import Control.Monad.State -- test | 20 | import Control.Monad.State -- test |
21 | import Text.Printf -- test | 21 | import Text.Printf -- test |
22 | 22 | ||
23 | 23 | ||
24 | type Index = Int | 24 | type Index = Int |
25 | 25 | ||
26 | 26 | ||
27 | data Store a = Store | 27 | data Store a = Store |
28 | { objects :: Vector (Maybe a) -- ^ An array of objects. | 28 | { objects :: Vector (Maybe a) -- ^ An array of objects. |
29 | , last :: Index -- ^ The greatest index assigned so far. | 29 | , last :: Index -- ^ The greatest index assigned so far. |
30 | } | 30 | } |
31 | deriving Show | 31 | deriving Show |
32 | 32 | ||
33 | 33 | ||
34 | instance Functor Store where | 34 | instance Functor Store where |
35 | fmap f (Store objects last) = Store (fmap (fmap f) objects) last | 35 | fmap f (Store objects last) = Store (fmap (fmap f) objects) last |
36 | 36 | ||
37 | 37 | ||
38 | -- | Create an empty store. | 38 | -- | Create an empty store. |
39 | emptyStore :: Store a | 39 | emptyStore :: Store a |
40 | emptyStore = Store V.empty (-1) | 40 | emptyStore = Store V.empty (-1) |
41 | 41 | ||
42 | 42 | ||
43 | -- | Store the given element in the store. | 43 | -- | Store the given element in the store. |
44 | store :: a -> Store a -> (Index, Store a) | 44 | store :: a -> Store a -> (Index, Store a) |
45 | store elem s@(Store objects last) = | 45 | store elem s@(Store objects last) = |
46 | if last == V.length objects - 1 | 46 | if last == V.length objects - 1 |
47 | then case findIndex isNothing objects of | 47 | then case findIndex isNothing objects of |
48 | Just i -> assign i elem s | 48 | Just i -> assign i elem s |
49 | Nothing -> store elem $ Store (objects V.++ V.replicate (max 1 last + 1) Nothing) last | 49 | Nothing -> store elem $ Store (objects V.++ V.replicate (max 1 last + 1) Nothing) last |
50 | else | 50 | else |
51 | assign (last+1) elem s | 51 | assign (last+1) elem s |
52 | 52 | ||
53 | 53 | ||
54 | -- Assign a slot the given element in the store. | 54 | -- Assign a slot the given element in the store. |
55 | assign :: Index -> a -> Store a -> (Index, Store a) | 55 | assign :: Index -> a -> Store a -> (Index, Store a) |
56 | assign i elem (Store objects last) = | 56 | assign i elem (Store objects last) = |
57 | let objects' = objects // [(i,Just elem)] | 57 | let objects' = objects // [(i,Just elem)] |
58 | in (i, Store objects' (max last i)) | 58 | in (i, Store objects' (max last i)) |
59 | 59 | ||
60 | 60 | ||
61 | -- | Store the given elements in the store. | 61 | -- | Store the given elements in the store. |
62 | storel :: [a] -> Store a -> ([Index], Store a) | 62 | storel :: [a] -> Store a -> ([Index], Store a) |
63 | storel elems s@(Store objects last) = | 63 | storel elems s@(Store objects last) = |
64 | let n = Prelude.length elems | 64 | let n = Prelude.length elems |
65 | (count, slots) = freeSlots objects | 65 | (count, slots) = freeSlots objects |
66 | in | 66 | in |
67 | let -- place count elements in free slots. | 67 | let -- place count elements in free slots. |
68 | (is, s'') = storeInSlots slots (Prelude.take count elems) s | 68 | (is, s'') = storeInSlots slots (Prelude.take count elems) s |
69 | 69 | ||
70 | -- append the remaining elements | 70 | -- append the remaining elements |
71 | (is', s') = append (Prelude.drop count elems) s'' | 71 | (is', s') = append (Prelude.drop count elems) s'' |
72 | in | 72 | in |
73 | (is Prelude.++ is', s') | 73 | (is Prelude.++ is', s') |
74 | 74 | ||
75 | 75 | ||
76 | -- Count and return the free slots. | 76 | -- Count and return the free slots. |
77 | freeSlots :: Vector (Maybe a) -> (Int, Vector Int) | 77 | freeSlots :: Vector (Maybe a) -> (Int, Vector Int) |
78 | freeSlots v = let is = findIndices isNothing v in (V.length is, is) | 78 | freeSlots v = let is = findIndices isNothing v in (V.length is, is) |
79 | 79 | ||
80 | 80 | ||
81 | -- Store the given elements in the given slots. | 81 | -- Store the given elements in the given slots. |
82 | -- Pre: valid indices. | 82 | -- Pre: valid indices. |
83 | storeInSlots :: Vector Int -> [a] -> Store a -> ([Index], Store a) | 83 | storeInSlots :: Vector Int -> [a] -> Store a -> ([Index], Store a) |
84 | storeInSlots is elems (Store objects last) = | 84 | storeInSlots is elems (Store objects last) = |
85 | let objects' = V.update_ objects is (V.fromList $ fmap Just elems) | 85 | let objects' = V.update_ objects is (V.fromList $ fmap Just elems) |
86 | last' = let i = V.length is - 1 | 86 | last' = let i = V.length is - 1 |
87 | in if i < 0 then last else max last $ is ! i | 87 | in if i < 0 then last else max last $ is ! i |
88 | in | 88 | in |
89 | (V.toList is, Store objects' last') | 89 | (V.toList is, Store objects' last') |
90 | 90 | ||
91 | 91 | ||
92 | -- Append the given elements to the last slot of the store, making space if necessary. | 92 | -- Append the given elements to the last slot of the store, making space if necessary. |
93 | append :: [a] -> Store a -> ([Index], Store a) | 93 | append :: [a] -> Store a -> ([Index], Store a) |
94 | append elems (Store objects last) = | 94 | append elems (Store objects last) = |
95 | let n = Prelude.length elems | 95 | let n = Prelude.length elems |
96 | indices = [last+1..last+n] | 96 | indices = [last+1..last+n] |
97 | objects'' = if V.length objects <= last+n | 97 | objects'' = if V.length objects <= last+n |
98 | then objects V.++ V.replicate n Nothing | 98 | then objects V.++ V.replicate n Nothing |
99 | else objects | 99 | else objects |
100 | objects' = objects'' // (Prelude.zipWith (,) indices (fmap Just elems)) | 100 | objects' = objects'' // (Prelude.zipWith (,) indices (fmap Just elems)) |
101 | in | 101 | in |
102 | (indices, Store objects' $ last+n) | 102 | (indices, Store objects' $ last+n) |
103 | 103 | ||
104 | 104 | ||
105 | -- | Free the given slot. | 105 | -- | Free the given slot. |
106 | storeFree :: Index -> Store a -> Store a | 106 | storeFree :: Index -> Store a -> Store a |
107 | storeFree i (Store objects last) = | 107 | storeFree i (Store objects last) = |
108 | let objects' = objects // [(i,Nothing)] | 108 | let objects' = objects // [(i,Nothing)] |
109 | in if i == last | 109 | in if i == last |
110 | then case findLastIndex isJust objects' of | 110 | then case findLastIndex isJust objects' of |
111 | Just j -> Store objects' j | 111 | Just j -> Store objects' j |
112 | Nothing -> Store objects' 0 | 112 | Nothing -> Store objects' 0 |
113 | else | 113 | else |
114 | Store objects' last | 114 | Store objects' last |
115 | 115 | ||
116 | 116 | ||
117 | findLastIndex :: (a -> Bool) -> Vector a -> Maybe Index | 117 | findLastIndex :: (a -> Bool) -> Vector a -> Maybe Index |
118 | findLastIndex p v = findLastIndex' p v Nothing 0 | 118 | findLastIndex p v = findLastIndex' p v Nothing 0 |
119 | where | 119 | where |
120 | findLastIndex' p v current i = | 120 | findLastIndex' p v current i = |
121 | if i >= V.length v then current | 121 | if i >= V.length v then current |
122 | else if p $ v V.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) | 122 | else if p $ v V.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) |
123 | else findLastIndex' p v current (i+1) | 123 | else findLastIndex' p v current (i+1) |
124 | 124 | ||
125 | 125 | ||
126 | -- | Free the given slots. | 126 | -- | Free the given slots. |
127 | storeFreel :: [Index] -> Store a -> Store a | 127 | storeFreel :: [Index] -> Store a -> Store a |
128 | storeFreel is (Store objects last) = | 128 | storeFreel is (Store objects last) = |
129 | let objects' = objects // Prelude.zipWith (,) is (repeat Nothing) | 129 | let objects' = objects // Prelude.zipWith (,) is (repeat Nothing) |
130 | last' = case L.find (==last) is of | 130 | last' = case L.find (==last) is of |
131 | Nothing -> last | 131 | Nothing -> last |
132 | Just _ -> case findLastIndex isJust objects' of | 132 | Just _ -> case findLastIndex isJust objects' of |
133 | Just j -> j | 133 | Just j -> j |
134 | Nothing -> (-1) | 134 | Nothing -> (-1) |
135 | in | 135 | in |
136 | Store objects' last' | 136 | Store objects' last' |
137 | 137 | ||
138 | 138 | ||
139 | -- | Access the element in the given slot. | 139 | -- | Access the element in the given slot. |
140 | element :: Index -> Store a -> Maybe a | 140 | element :: Index -> Store a -> Maybe a |
141 | element index (Store objects _) = objects V.! index | 141 | element index (Store objects _) = objects V.! index |
142 | 142 | ||
143 | 143 | ||
144 | -- | Set the element in the given slot. | 144 | -- | Set the element in the given slot. |
145 | setElement :: Index -> a -> Store a -> Store a | 145 | setElement :: Index -> a -> Store a -> Store a |
146 | setElement index elem s = s { objects = objects s // [(index,Just elem)] } | 146 | setElement index elem s = s { objects = objects s // [(index,Just elem)] } |
147 | 147 | ||
148 | 148 | ||
149 | -- | Apply a function to the element in the given slot. | 149 | -- | Apply a function to the element in the given slot. |
150 | withElement :: Index -> Store a -> (a -> a) -> Store a | 150 | withElement :: Index -> Store a -> (a -> a) -> Store a |
151 | withElement index store f = store { objects = objects' } | 151 | withElement index store f = store { objects = objects' } |
152 | where | 152 | where |
153 | objects' = objects store // [(index, obj')] | 153 | objects' = objects store // [(index, obj')] |
154 | obj' = case element index store of | 154 | obj' = case element index store of |
155 | Nothing -> Nothing | 155 | Nothing -> Nothing |
156 | Just x -> Just $ f x | 156 | Just x -> Just $ f x |
157 | 157 | ||
158 | 158 | ||
159 | -- test | 159 | -- test |
160 | test :: IO () | 160 | test :: IO () |
161 | test = evalStateT test' emptyStore | 161 | test = evalStateT test' emptyStore |
162 | 162 | ||
163 | 163 | ||
164 | test' :: StateT (Store Int) IO () | 164 | test' :: StateT (Store Int) IO () |
165 | test' = do | 165 | test' = do |
166 | x <- store' 1 | 166 | x <- store' 1 |
167 | y <- store' 2 | 167 | y <- store' 2 |
168 | z <- store' 3 | 168 | z <- store' 3 |
169 | w <- store' 4 | 169 | w <- store' 4 |
170 | free y | 170 | free y |
171 | store' 5 | 171 | store' 5 |
172 | free w | 172 | free w |
173 | store' 6 | 173 | store' 6 |
174 | a <- store' 7 | 174 | a <- store' 7 |
175 | free a | 175 | free a |
176 | store' 8 | 176 | store' 8 |
177 | return () | 177 | return () |
178 | 178 | ||
179 | 179 | ||
180 | store' :: Int -> StateT (Store Int) IO Int | 180 | store' :: Int -> StateT (Store Int) IO Int |
181 | store' elem = do | 181 | store' elem = do |
182 | s <- get | 182 | s <- get |
183 | let (i, s') = store elem s | 183 | let (i, s') = store elem s |
184 | put s' | 184 | put s' |
185 | lift $ printf "%d stored at %d; %s\n" elem i (show s') | 185 | lift $ printf "%d stored at %d; %s\n" elem i (show s') |
186 | return i | 186 | return i |
187 | 187 | ||
188 | 188 | ||
189 | free :: Index -> StateT (Store Int) IO () | 189 | free :: Index -> StateT (Store Int) IO () |
190 | free i = do | 190 | free i = do |
191 | s <- get | 191 | s <- get |
192 | let s' = storeFree i s | 192 | let s' = storeFree i s |
193 | put s' | 193 | put s' |
194 | lift $ printf "Slot %d freed; %s\n" i (show s') | 194 | lift $ printf "Slot %d freed; %s\n" i (show s') |
195 | 195 | ||
diff --git a/Spear/Sys/Store/ID.hs b/Spear/Sys/Store/ID.hs index a4da3d0..4be406d 100644 --- a/Spear/Sys/Store/ID.hs +++ b/Spear/Sys/Store/ID.hs | |||
@@ -1,106 +1,106 @@ | |||
1 | module Spear.Sys.Store.ID | 1 | module Spear.Sys.Store.ID |
2 | ( | 2 | ( |
3 | ID | 3 | ID |
4 | , IDStore | 4 | , IDStore |
5 | , emptyIDStore | 5 | , emptyIDStore |
6 | , newID | 6 | , newID |
7 | , freeID | 7 | , freeID |
8 | ) | 8 | ) |
9 | where | 9 | where |
10 | 10 | ||
11 | 11 | ||
12 | import Data.Vector.Unboxed as U | 12 | import Data.Vector.Unboxed as U |
13 | import Control.Monad.State -- test | 13 | import Control.Monad.State -- test |
14 | import Text.Printf -- test | 14 | import Text.Printf -- test |
15 | 15 | ||
16 | 16 | ||
17 | type ID = Int | 17 | type ID = Int |
18 | 18 | ||
19 | 19 | ||
20 | data IDStore = IDStore | 20 | data IDStore = IDStore |
21 | { assigned :: Vector Bool -- ^ A bit array indicating used IDs. | 21 | { assigned :: Vector Bool -- ^ A bit array indicating used IDs. |
22 | , last :: Int -- ^ The greatest ID assigned so far. | 22 | , last :: Int -- ^ The greatest ID assigned so far. |
23 | } | 23 | } |
24 | deriving Show | 24 | deriving Show |
25 | 25 | ||
26 | 26 | ||
27 | -- | Create an empty ID store. | 27 | -- | Create an empty ID store. |
28 | emptyIDStore :: IDStore | 28 | emptyIDStore :: IDStore |
29 | emptyIDStore = IDStore U.empty (-1) | 29 | emptyIDStore = IDStore U.empty (-1) |
30 | 30 | ||
31 | 31 | ||
32 | -- | Request an ID from the ID store. | 32 | -- | Request an ID from the ID store. |
33 | newID :: IDStore -> (ID, IDStore) | 33 | newID :: IDStore -> (ID, IDStore) |
34 | newID store@(IDStore assigned last) = | 34 | newID store@(IDStore assigned last) = |
35 | if last == U.length assigned - 1 | 35 | if last == U.length assigned - 1 |
36 | then case findIndex (==False) assigned of | 36 | then case findIndex (==False) assigned of |
37 | Just i -> assign i store | 37 | Just i -> assign i store |
38 | Nothing -> newID $ IDStore (assigned U.++ U.replicate (max 1 last + 1) False) last | 38 | Nothing -> newID $ IDStore (assigned U.++ U.replicate (max 1 last + 1) False) last |
39 | else | 39 | else |
40 | assign (last+1) store | 40 | assign (last+1) store |
41 | 41 | ||
42 | 42 | ||
43 | -- Assign the given ID in the ID store. | 43 | -- Assign the given ID in the ID store. |
44 | assign :: ID -> IDStore -> (ID, IDStore) | 44 | assign :: ID -> IDStore -> (ID, IDStore) |
45 | assign i (IDStore assigned last) = | 45 | assign i (IDStore assigned last) = |
46 | let assigned' = assigned // [(i,True)] | 46 | let assigned' = assigned // [(i,True)] |
47 | in (i, IDStore assigned' (max last i)) | 47 | in (i, IDStore assigned' (max last i)) |
48 | 48 | ||
49 | 49 | ||
50 | -- | Free the given ID from the ID store. | 50 | -- | Free the given ID from the ID store. |
51 | freeID :: ID -> IDStore -> IDStore | 51 | freeID :: ID -> IDStore -> IDStore |
52 | freeID i (IDStore assigned last) = | 52 | freeID i (IDStore assigned last) = |
53 | let assigned' = assigned // [(i,False)] | 53 | let assigned' = assigned // [(i,False)] |
54 | in if i == last | 54 | in if i == last |
55 | then case findLastIndex (==True) assigned' of | 55 | then case findLastIndex (==True) assigned' of |
56 | Just j -> IDStore assigned' j | 56 | Just j -> IDStore assigned' j |
57 | Nothing -> IDStore assigned' 0 | 57 | Nothing -> IDStore assigned' 0 |
58 | else | 58 | else |
59 | IDStore assigned' last | 59 | IDStore assigned' last |
60 | 60 | ||
61 | 61 | ||
62 | findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int | 62 | findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int |
63 | findLastIndex p v = findLastIndex' p v Nothing 0 | 63 | findLastIndex p v = findLastIndex' p v Nothing 0 |
64 | where | 64 | where |
65 | findLastIndex' p v current i = | 65 | findLastIndex' p v current i = |
66 | if i >= U.length v then current | 66 | if i >= U.length v then current |
67 | else if p $ v U.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) | 67 | else if p $ v U.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) |
68 | else findLastIndex' p v current (i+1) | 68 | else findLastIndex' p v current (i+1) |
69 | 69 | ||
70 | 70 | ||
71 | -- test | 71 | -- test |
72 | test :: IO () | 72 | test :: IO () |
73 | test = evalStateT test' emptyIDStore | 73 | test = evalStateT test' emptyIDStore |
74 | 74 | ||
75 | 75 | ||
76 | test' :: StateT IDStore IO () | 76 | test' :: StateT IDStore IO () |
77 | test' = do | 77 | test' = do |
78 | x <- request | 78 | x <- request |
79 | y <- request | 79 | y <- request |
80 | z <- request | 80 | z <- request |
81 | w <- request | 81 | w <- request |
82 | free y | 82 | free y |
83 | request | 83 | request |
84 | free w | 84 | free w |
85 | request | 85 | request |
86 | a <- request | 86 | a <- request |
87 | free a | 87 | free a |
88 | request | 88 | request |
89 | return () | 89 | return () |
90 | 90 | ||
91 | 91 | ||
92 | request :: StateT IDStore IO ID | 92 | request :: StateT IDStore IO ID |
93 | request = do | 93 | request = do |
94 | store <- get | 94 | store <- get |
95 | let (i, store') = newID store | 95 | let (i, store') = newID store |
96 | put store' | 96 | put store' |
97 | lift $ printf "ID requested, got %d; %s\n" i (show store') | 97 | lift $ printf "ID requested, got %d; %s\n" i (show store') |
98 | return i | 98 | return i |
99 | 99 | ||
100 | 100 | ||
101 | free :: ID -> StateT IDStore IO () | 101 | free :: ID -> StateT IDStore IO () |
102 | free i = do | 102 | free i = do |
103 | store <- get | 103 | store <- get |
104 | let store' = freeID i store | 104 | let store' = freeID i store |
105 | put store' | 105 | put store' |
106 | lift $ printf "ID %d freed; %s\n" i (show store') | 106 | lift $ printf "ID %d freed; %s\n" i (show store') |
diff --git a/Spear/Sys/Timer.hs b/Spear/Sys/Timer.hs deleted file mode 100644 index a44f7f9..0000000 --- a/Spear/Sys/Timer.hs +++ /dev/null | |||
@@ -1,194 +0,0 @@ | |||
1 | {-# INCLUDE "Timer/Timer.h" #-} | ||
2 | {-# LINE 1 "Timer.hsc" #-} | ||
3 | {-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} | ||
4 | {-# LINE 2 "Timer.hsc" #-} | ||
5 | module Spear.Sys.Timer | ||
6 | ( | ||
7 | Timer | ||
8 | , initialiseTimingSubsystem | ||
9 | , newTimer | ||
10 | , tick | ||
11 | , reset | ||
12 | , stop | ||
13 | , start | ||
14 | , sleep | ||
15 | , getTime | ||
16 | , getDelta | ||
17 | , isRunning | ||
18 | ) | ||
19 | where | ||
20 | |||
21 | |||
22 | import Foreign | ||
23 | import Foreign.C.Types | ||
24 | import Control.Monad | ||
25 | import System.IO.Unsafe | ||
26 | |||
27 | |||
28 | |||
29 | {-# LINE 28 "Timer.hsc" #-} | ||
30 | type TimeReading = CDouble | ||
31 | |||
32 | {-# LINE 30 "Timer.hsc" #-} | ||
33 | |||
34 | data Timer = Timer { | ||
35 | getBaseTime :: TimeReading | ||
36 | , getPausedTime :: TimeReading | ||
37 | , getStopTime :: TimeReading | ||
38 | , getPrevTime :: TimeReading | ||
39 | , getCurTime :: TimeReading | ||
40 | , getDeltaTime :: CFloat | ||
41 | , getRunning :: CChar | ||
42 | } | ||
43 | |||
44 | |||
45 | |||
46 | {-# LINE 43 "Timer.hsc" #-} | ||
47 | |||
48 | |||
49 | instance Storable Timer where | ||
50 | sizeOf _ = (48) | ||
51 | {-# LINE 47 "Timer.hsc" #-} | ||
52 | alignment _ = alignment (undefined :: TimeReading) | ||
53 | |||
54 | peek ptr = do | ||
55 | baseTime <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr | ||
56 | {-# LINE 51 "Timer.hsc" #-} | ||
57 | pausedTime <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr | ||
58 | {-# LINE 52 "Timer.hsc" #-} | ||
59 | stopTime <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr | ||
60 | {-# LINE 53 "Timer.hsc" #-} | ||
61 | prevTime <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr | ||
62 | {-# LINE 54 "Timer.hsc" #-} | ||
63 | curTime <- (\hsc_ptr -> peekByteOff hsc_ptr 32) ptr | ||
64 | {-# LINE 55 "Timer.hsc" #-} | ||
65 | deltaTime <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr | ||
66 | {-# LINE 56 "Timer.hsc" #-} | ||
67 | stopped <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr | ||
68 | {-# LINE 57 "Timer.hsc" #-} | ||
69 | return $ Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped | ||
70 | |||
71 | poke ptr (Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped) = do | ||
72 | (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr baseTime | ||
73 | {-# LINE 61 "Timer.hsc" #-} | ||
74 | (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr pausedTime | ||
75 | {-# LINE 62 "Timer.hsc" #-} | ||
76 | (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr stopTime | ||
77 | {-# LINE 63 "Timer.hsc" #-} | ||
78 | (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr prevTime | ||
79 | {-# LINE 64 "Timer.hsc" #-} | ||
80 | (\hsc_ptr -> pokeByteOff hsc_ptr 32) ptr curTime | ||
81 | {-# LINE 65 "Timer.hsc" #-} | ||
82 | (\hsc_ptr -> pokeByteOff hsc_ptr 40) ptr deltaTime | ||
83 | {-# LINE 66 "Timer.hsc" #-} | ||
84 | (\hsc_ptr -> pokeByteOff hsc_ptr 44) ptr stopped | ||
85 | {-# LINE 67 "Timer.hsc" #-} | ||
86 | |||
87 | |||
88 | foreign import ccall "Timer.h timer_initialise_subsystem" | ||
89 | c_timer_initialise_subsystem :: IO () | ||
90 | |||
91 | foreign import ccall "Timer.h timer_initialise_timer" | ||
92 | c_timer_initialise_timer :: Ptr Timer -> IO () | ||
93 | |||
94 | foreign import ccall "Timer.h timer_tick" | ||
95 | c_timer_tick :: Ptr Timer -> IO () | ||
96 | |||
97 | foreign import ccall "Timer.h timer_reset" | ||
98 | c_timer_reset :: Ptr Timer -> IO () | ||
99 | |||
100 | foreign import ccall "Timer.h timer_stop" | ||
101 | c_timer_stop :: Ptr Timer -> IO () | ||
102 | |||
103 | foreign import ccall "Timer.h timer_start" | ||
104 | c_timer_start :: Ptr Timer -> IO () | ||
105 | |||
106 | foreign import ccall "Timer.h timer_sleep" | ||
107 | c_timer_sleep :: CFloat -> IO () | ||
108 | |||
109 | foreign import ccall "Timer.h timer_get_time" | ||
110 | c_timer_get_time :: Ptr Timer -> IO (CFloat) | ||
111 | |||
112 | foreign import ccall "Timer.h timer_get_delta" | ||
113 | c_timer_get_delta :: Ptr Timer -> IO (CFloat) | ||
114 | |||
115 | foreign import ccall "Timer.h timer_is_running" | ||
116 | c_timer_is_running :: Ptr Timer -> IO (CChar) | ||
117 | |||
118 | |||
119 | -- | Initialises the timing subsystem. | ||
120 | initialiseTimingSubsystem :: IO () | ||
121 | initialiseTimingSubsystem = c_timer_initialise_subsystem | ||
122 | |||
123 | |||
124 | -- | Creates a timer. | ||
125 | newTimer :: Timer | ||
126 | newTimer = unsafePerformIO . alloca $ \tptr -> do | ||
127 | c_timer_initialise_timer tptr | ||
128 | t <- peek tptr | ||
129 | return t | ||
130 | |||
131 | |||
132 | -- | Updates the timer. | ||
133 | tick :: Timer -> IO (Timer) | ||
134 | tick t = alloca $ \tptr -> do | ||
135 | poke tptr t | ||
136 | c_timer_tick tptr | ||
137 | t' <- peek tptr | ||
138 | return t' | ||
139 | |||
140 | |||
141 | -- | Resets the timer. | ||
142 | reset :: Timer -> IO (Timer) | ||
143 | reset t = alloca $ \tptr -> do | ||
144 | poke tptr t | ||
145 | c_timer_reset tptr | ||
146 | t' <- peek tptr | ||
147 | return t' | ||
148 | |||
149 | |||
150 | -- | Stops the timer. | ||
151 | stop :: Timer -> IO (Timer) | ||
152 | stop t = alloca $ \tptr -> do | ||
153 | poke tptr t | ||
154 | c_timer_stop tptr | ||
155 | t' <- peek tptr | ||
156 | return t' | ||
157 | |||
158 | |||
159 | -- | Starts the timer. | ||
160 | start :: Timer -> IO (Timer) | ||
161 | start t = alloca $ \tptr -> do | ||
162 | poke tptr t | ||
163 | c_timer_start tptr | ||
164 | t' <- peek tptr | ||
165 | return t' | ||
166 | |||
167 | |||
168 | -- | Puts the caller thread to sleep for the given number of seconds. | ||
169 | sleep :: Float -> IO () | ||
170 | sleep = c_timer_sleep . realToFrac | ||
171 | |||
172 | |||
173 | -- | Gets the timer's total running time. | ||
174 | getTime :: Timer -> Float | ||
175 | getTime t = unsafePerformIO . alloca $ \tptr -> do | ||
176 | poke tptr t | ||
177 | time <- c_timer_get_time tptr | ||
178 | return (realToFrac time) | ||
179 | |||
180 | |||
181 | -- | Gets the timer's delta since the last tick. | ||
182 | getDelta :: Timer -> Float | ||
183 | getDelta t = unsafePerformIO . alloca $ \tptr -> do | ||
184 | poke tptr t | ||
185 | dt <- c_timer_get_delta tptr | ||
186 | return (realToFrac dt) | ||
187 | |||
188 | |||
189 | -- | Returns true if the timer is running, false otherwise. | ||
190 | isRunning :: Timer -> Bool | ||
191 | isRunning t = unsafePerformIO . alloca $ \tptr -> do | ||
192 | poke tptr t | ||
193 | running <- c_timer_is_running tptr | ||
194 | return (running /= 0) | ||
diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc index c800c8d..16f377e 100644 --- a/Spear/Sys/Timer.hsc +++ b/Spear/Sys/Timer.hsc | |||
@@ -1,175 +1,150 @@ | |||
1 | {-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} | 1 | {-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} |
2 | module Spear.Sys.Timer | 2 | module Spear.Sys.Timer |
3 | ( | 3 | ( |
4 | Timer | 4 | Timer |
5 | , initialiseTimingSubsystem | 5 | , newTimer |
6 | , newTimer | 6 | , tick |
7 | , tick | 7 | , start |
8 | , reset | 8 | , stop |
9 | , stop | 9 | , reset |
10 | , start | 10 | , getTime |
11 | , sleep | 11 | , getDelta |
12 | , getTime | 12 | , isRunning |
13 | , getDelta | 13 | , sleep |
14 | , isRunning | 14 | ) |
15 | ) | 15 | where |
16 | where | 16 | |
17 | 17 | import Foreign.C.Types | |
18 | 18 | import Foreign.Marshal.Alloc (alloca) | |
19 | import Foreign hiding (unsafePerformIO) | 19 | import Foreign.Ptr |
20 | import Foreign.C.Types | 20 | import Foreign.Storable |
21 | import Control.Monad | 21 | import Control.Monad |
22 | import System.IO.Unsafe | 22 | import System.IO.Unsafe |
23 | 23 | ||
24 | 24 | #ifdef WIN32 | |
25 | #ifdef WIN32 | 25 | type TimeReading = CULLong |
26 | type TimeReading = CULLong | 26 | #else |
27 | #else | 27 | type TimeReading = CDouble |
28 | type TimeReading = CDouble | 28 | #endif |
29 | #endif | 29 | |
30 | 30 | data Timer = Timer | |
31 | data Timer = Timer { | 31 | { getBaseTime :: TimeReading |
32 | getBaseTime :: TimeReading | 32 | , getPausedTime :: TimeReading |
33 | , getPausedTime :: TimeReading | 33 | , getStopTime :: TimeReading |
34 | , getStopTime :: TimeReading | 34 | , getPrevTime :: TimeReading |
35 | , getPrevTime :: TimeReading | 35 | , getCurTime :: TimeReading |
36 | , getCurTime :: TimeReading | 36 | , getDeltaTime :: CFloat |
37 | , getDeltaTime :: CFloat | 37 | , getRunning :: CChar |
38 | , getRunning :: CChar | 38 | } |
39 | } | 39 | |
40 | 40 | #include "Timer/Timer.h" | |
41 | 41 | ||
42 | #include "Timer/Timer.h" | 42 | instance Storable Timer where |
43 | 43 | sizeOf _ = #{size Timer} | |
44 | 44 | alignment _ = alignment (undefined :: TimeReading) | |
45 | instance Storable Timer where | 45 | |
46 | sizeOf _ = #{size timer} | 46 | peek ptr = do |
47 | alignment _ = alignment (undefined :: TimeReading) | 47 | baseTime <- #{peek Timer, baseTime} ptr |
48 | 48 | pausedTime <- #{peek Timer, pausedTime} ptr | |
49 | peek ptr = do | 49 | stopTime <- #{peek Timer, stopTime} ptr |
50 | baseTime <- #{peek timer, baseTime} ptr | 50 | prevTime <- #{peek Timer, prevTime} ptr |
51 | pausedTime <- #{peek timer, pausedTime} ptr | 51 | curTime <- #{peek Timer, curTime} ptr |
52 | stopTime <- #{peek timer, stopTime} ptr | 52 | deltaTime <- #{peek Timer, deltaTime} ptr |
53 | prevTime <- #{peek timer, prevTime} ptr | 53 | stopped <- #{peek Timer, stopped} ptr |
54 | curTime <- #{peek timer, curTime} ptr | 54 | return $ Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped |
55 | deltaTime <- #{peek timer, deltaTime} ptr | 55 | |
56 | stopped <- #{peek timer, stopped} ptr | 56 | poke ptr (Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped) = do |
57 | return $ Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped | 57 | #{poke Timer, baseTime} ptr baseTime |
58 | 58 | #{poke Timer, pausedTime} ptr pausedTime | |
59 | poke ptr (Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped) = do | 59 | #{poke Timer, stopTime} ptr stopTime |
60 | #{poke timer, baseTime} ptr baseTime | 60 | #{poke Timer, prevTime} ptr prevTime |
61 | #{poke timer, pausedTime} ptr pausedTime | 61 | #{poke Timer, curTime} ptr curTime |
62 | #{poke timer, stopTime} ptr stopTime | 62 | #{poke Timer, deltaTime} ptr deltaTime |
63 | #{poke timer, prevTime} ptr prevTime | 63 | #{poke Timer, stopped} ptr stopped |
64 | #{poke timer, curTime} ptr curTime | 64 | |
65 | #{poke timer, deltaTime} ptr deltaTime | 65 | foreign import ccall unsafe "Timer.h timer_init" |
66 | #{poke timer, stopped} ptr stopped | 66 | c_timer_init :: Ptr Timer -> IO () |
67 | 67 | ||
68 | 68 | foreign import ccall unsafe "Timer.h timer_tick" | |
69 | foreign import ccall "Timer.h timer_initialise_subsystem" | 69 | c_timer_tick :: Ptr Timer -> IO () |
70 | c_timer_initialise_subsystem :: IO () | 70 | |
71 | 71 | foreign import ccall unsafe "Timer.h timer_start" | |
72 | foreign import ccall "Timer.h timer_initialise_timer" | 72 | c_timer_start :: Ptr Timer -> IO () |
73 | c_timer_initialise_timer :: Ptr Timer -> IO () | 73 | |
74 | 74 | foreign import ccall unsafe "Timer.h timer_stop" | |
75 | foreign import ccall "Timer.h timer_tick" | 75 | c_timer_stop :: Ptr Timer -> IO () |
76 | c_timer_tick :: Ptr Timer -> IO () | 76 | |
77 | 77 | foreign import ccall unsafe "Timer.h timer_reset" | |
78 | foreign import ccall "Timer.h timer_reset" | 78 | c_timer_reset :: Ptr Timer -> IO () |
79 | c_timer_reset :: Ptr Timer -> IO () | 79 | |
80 | 80 | foreign import ccall unsafe "Timer.h timer_get_time" | |
81 | foreign import ccall "Timer.h timer_stop" | 81 | c_timer_get_time :: Ptr Timer -> IO (CDouble) |
82 | c_timer_stop :: Ptr Timer -> IO () | 82 | |
83 | 83 | foreign import ccall unsafe "Timer.h timer_get_delta" | |
84 | foreign import ccall "Timer.h timer_start" | 84 | c_timer_get_delta :: Ptr Timer -> IO (CFloat) |
85 | c_timer_start :: Ptr Timer -> IO () | 85 | |
86 | 86 | foreign import ccall unsafe "Timer.h timer_is_running" | |
87 | foreign import ccall "Timer.h timer_sleep" | 87 | c_timer_is_running :: Ptr Timer -> IO (CChar) |
88 | c_timer_sleep :: CFloat -> IO () | 88 | |
89 | 89 | foreign import ccall "Timer.h timer_sleep" | |
90 | foreign import ccall "Timer.h timer_get_time" | 90 | c_timer_sleep :: CFloat -> IO () |
91 | c_timer_get_time :: Ptr Timer -> IO (CFloat) | 91 | |
92 | 92 | -- | Construct a new timer. | |
93 | foreign import ccall "Timer.h timer_get_delta" | 93 | newTimer :: Timer |
94 | c_timer_get_delta :: Ptr Timer -> IO (CFloat) | 94 | newTimer = unsafePerformIO . unsafeInterleaveIO . alloca $ \tptr -> do |
95 | 95 | c_timer_init tptr | |
96 | foreign import ccall "Timer.h timer_is_running" | 96 | peek tptr |
97 | c_timer_is_running :: Ptr Timer -> IO (CChar) | 97 | |
98 | 98 | -- | Update the timer. | |
99 | 99 | tick :: Timer -> IO (Timer) | |
100 | -- | Initialises the timing subsystem. | 100 | tick t = alloca $ \tptr -> do |
101 | initialiseTimingSubsystem :: IO () | 101 | poke tptr t |
102 | initialiseTimingSubsystem = c_timer_initialise_subsystem | 102 | c_timer_tick tptr |
103 | 103 | peek tptr | |
104 | 104 | ||
105 | -- | Creates a timer. | 105 | -- | Start the timer. |
106 | newTimer :: Timer | 106 | start :: Timer -> IO (Timer) |
107 | newTimer = unsafePerformIO . alloca $ \tptr -> do | 107 | start t = alloca $ \tptr -> do |
108 | c_timer_initialise_timer tptr | 108 | poke tptr t |
109 | t <- peek tptr | 109 | c_timer_start tptr |
110 | return t | 110 | t' <- peek tptr |
111 | 111 | return t' | |
112 | 112 | ||
113 | -- | Updates the timer. | 113 | -- | Stop the timer. |
114 | tick :: Timer -> IO (Timer) | 114 | stop :: Timer -> IO (Timer) |
115 | tick t = alloca $ \tptr -> do | 115 | stop t = alloca $ \tptr -> do |
116 | poke tptr t | 116 | poke tptr t |
117 | c_timer_tick tptr | 117 | c_timer_stop tptr |
118 | t' <- peek tptr | 118 | peek tptr |
119 | return t' | 119 | |
120 | 120 | -- | Reset the timer. | |
121 | 121 | reset :: Timer -> IO (Timer) | |
122 | -- | Resets the timer. | 122 | reset t = alloca $ \tptr -> do |
123 | reset :: Timer -> IO (Timer) | 123 | poke tptr t |
124 | reset t = alloca $ \tptr -> do | 124 | c_timer_reset tptr |
125 | poke tptr t | 125 | peek tptr |
126 | c_timer_reset tptr | 126 | |
127 | t' <- peek tptr | 127 | -- | Get the timer's total running time. |
128 | return t' | 128 | getTime :: Timer -> Double |
129 | 129 | getTime t = unsafeDupablePerformIO . alloca $ \tptr -> do | |
130 | 130 | poke tptr t | |
131 | -- | Stops the timer. | 131 | time <- c_timer_get_time tptr |
132 | stop :: Timer -> IO (Timer) | 132 | return (realToFrac time) |
133 | stop t = alloca $ \tptr -> do | 133 | |
134 | poke tptr t | 134 | -- | Get the time elapsed between the last two ticks. |
135 | c_timer_stop tptr | 135 | getDelta :: Timer -> Float |
136 | t' <- peek tptr | 136 | getDelta t = unsafeDupablePerformIO . alloca $ \tptr -> do |
137 | return t' | 137 | poke tptr t |
138 | 138 | dt <- c_timer_get_delta tptr | |
139 | 139 | return (realToFrac dt) | |
140 | -- | Starts the timer. | 140 | |
141 | start :: Timer -> IO (Timer) | 141 | -- | Return true if the timer is running (not stopped), false otherwise. |
142 | start t = alloca $ \tptr -> do | 142 | isRunning :: Timer -> Bool |
143 | poke tptr t | 143 | isRunning t = unsafeDupablePerformIO . alloca $ \tptr -> do |
144 | c_timer_start tptr | 144 | poke tptr t |
145 | t' <- peek tptr | 145 | running <- c_timer_is_running tptr |
146 | return t' | 146 | return (running /= 0) |
147 | 147 | ||
148 | 148 | -- | Put the caller thread to sleep for the given number of seconds. | |
149 | -- | Puts the caller thread to sleep for the given number of seconds. | 149 | sleep :: Float -> IO () |
150 | sleep :: Float -> IO () | 150 | sleep = c_timer_sleep . realToFrac |
151 | sleep = c_timer_sleep . realToFrac | ||
152 | |||
153 | |||
154 | -- | Gets the timer's total running time. | ||
155 | getTime :: Timer -> Float | ||
156 | getTime t = unsafePerformIO . alloca $ \tptr -> do | ||
157 | poke tptr t | ||
158 | time <- c_timer_get_time tptr | ||
159 | return (realToFrac time) | ||
160 | |||
161 | |||
162 | -- | Gets the timer's delta since the last tick. | ||
163 | getDelta :: Timer -> Float | ||
164 | getDelta t = unsafePerformIO . alloca $ \tptr -> do | ||
165 | poke tptr t | ||
166 | dt <- c_timer_get_delta tptr | ||
167 | return (realToFrac dt) | ||
168 | |||
169 | |||
170 | -- | Returns true if the timer is running, false otherwise. | ||
171 | isRunning :: Timer -> Bool | ||
172 | isRunning t = unsafePerformIO . alloca $ \tptr -> do | ||
173 | poke tptr t | ||
174 | running <- c_timer_is_running tptr | ||
175 | return (running /= 0) | ||
diff --git a/Spear/Sys/Timer/Timer.h b/Spear/Sys/Timer/Timer.h index 60b81f7..308509c 100644 --- a/Spear/Sys/Timer/Timer.h +++ b/Spear/Sys/Timer/Timer.h | |||
@@ -1,73 +1,130 @@ | |||
1 | #ifndef _SPEAR_TIMER_H | 1 | #pragma once |
2 | #define _SPEAR_TIMER_H | ||
3 | 2 | ||
3 | #ifdef WIN32 | ||
4 | #ifdef _MSC_VER | 4 | #ifdef _MSC_VER |
5 | #ifdef DLL_EXPORT | 5 | typedef __int64 timeReading; |
6 | #define DECLDIR __declspec(dllexport) | ||
7 | #else | ||
8 | #define DECLDIR __declspec(dllimport) | ||
9 | #endif | ||
10 | #else | 6 | #else |
11 | #define DECLDIR | 7 | typedef __UINT64_TYPE__ timeReading; |
12 | #endif | 8 | #endif |
13 | |||
14 | #ifdef WIN32 | ||
15 | #ifdef _MSC_VER | ||
16 | typedef __int64 timeReading; | ||
17 | #else | ||
18 | typedef __UINT64_TYPE__ timeReading; | ||
19 | #endif | ||
20 | #else | 9 | #else |
21 | typedef double timeReading; | 10 | typedef __UINT64_TYPE__ timeReading; |
22 | #endif | 11 | #endif |
23 | 12 | ||
24 | #ifdef __cplusplus | 13 | #ifdef __cplusplus |
25 | extern C { | 14 | extern "C" { |
26 | #endif | 15 | #endif |
27 | 16 | ||
17 | /* | ||
18 | Header: Timer | ||
19 | A high resolution timer module. | ||
20 | */ | ||
21 | |||
22 | /* | ||
23 | Struct: Timer | ||
24 | */ | ||
28 | typedef struct | 25 | typedef struct |
29 | { | 26 | { |
30 | timeReading baseTime; | 27 | timeReading baseTime; // The instant since we start timing. |
31 | timeReading pausedTime; | 28 | timeReading stopTime; // The instant the timer is stopped. |
32 | timeReading stopTime; | 29 | timeReading prevTime; // The instant the timer was ticked prior to the last tick. |
33 | timeReading prevTime; | 30 | timeReading curTime; // The instant the timer was last ticked. |
34 | timeReading curTime; | 31 | timeReading pausedTime; // Amount of time the timer has been stopped for. |
35 | float deltaTime; | 32 | float deltaTime; // Amount of time elapsed since the last call to tick. |
36 | char stopped; | 33 | char stopped; |
37 | } timer; | 34 | } Timer; |
35 | |||
36 | /* | ||
37 | Function: timer_init | ||
38 | Construct a new timer. | ||
39 | |||
40 | The timer is initialised by making a call to reset(). Since time | ||
41 | calculations are measured from the instant the timer is reset (base time), | ||
42 | you probably want to make a manual call to reset() at the start of | ||
43 | your application, otherwise the application will be measuring times | ||
44 | from the instant the timer's constructor is called, which can be error prone. | ||
45 | |||
46 | A call to start() must be made prior to any time calculations, as the | ||
47 | timer is initialised as stopped. | ||
48 | */ | ||
49 | void timer_init (Timer*); | ||
38 | 50 | ||
39 | /// Initialises the timing subsystem. | 51 | /* |
40 | void DECLDIR timer_initialise_subsystem (); | 52 | Function: timer_tick |
53 | Update the timer's values. | ||
41 | 54 | ||
42 | /// Initialises a timer. | 55 | This function updates the timer's running time and caches the time |
43 | void DECLDIR timer_initialise_timer (timer* t); | 56 | elapsed since the last tick or since the start if this is the first |
57 | tick after the last call to start(). | ||
44 | 58 | ||
45 | /// Call every frame. | 59 | This function has no effect on a stopped ticker. |
46 | void DECLDIR timer_tick (timer* t); | 60 | */ |
61 | void timer_tick (Timer*); | ||
47 | 62 | ||
48 | /// Call before message loop. | 63 | /* |
49 | void DECLDIR timer_reset (timer* t); | 64 | Function: timer_start |
65 | Start the timer. | ||
50 | 66 | ||
51 | /// Call when paused. | 67 | This function starts the timer for the first time or resumes it |
52 | void DECLDIR timer_stop (timer* t); | 68 | after a call to stop(). |
53 | 69 | ||
54 | /// Call when unpaused. | 70 | Note that this function does not reset the timer's base time; |
55 | void DECLDIR timer_start (timer* t); | 71 | it's only a mechanism to resume a stopped timer. |
72 | */ | ||
73 | void timer_start (Timer*); | ||
56 | 74 | ||
57 | /// Puts the caller thread to sleep for the given number of seconds. | 75 | /* |
58 | void DECLDIR timer_sleep (float seconds); | 76 | Function: timer_stop |
77 | Stop the timer. | ||
59 | 78 | ||
60 | /// Returns total running time in seconds. | 79 | This function essentially freezes time; any values dependent on |
61 | float DECLDIR timer_get_time (timer* t); | 80 | the timer will behave as if time had not passed since the moment |
81 | the timer was stopped. | ||
62 | 82 | ||
63 | /// Returns the elapsed time in seconds. | 83 | To resume the timer call start(). |
64 | float DECLDIR timer_get_delta (timer* t); | 84 | */ |
85 | void timer_stop (Timer*); | ||
65 | 86 | ||
66 | /// Gets the timer's running state. | 87 | /* |
67 | char DECLDIR timer_is_running (timer* t); | 88 | Function: timer_reset |
89 | Reset the timer. | ||
90 | |||
91 | This function resets all of the timer's values such as running and | ||
92 | stop times and sets the timer to stopped. The total running time is | ||
93 | then measured from the instant the timer is reset, making the timer | ||
94 | behave as a newly constructed one. | ||
95 | |||
96 | A call to start() must be made prior to any further time calculations. | ||
97 | */ | ||
98 | void timer_reset (Timer*); | ||
99 | |||
100 | /* | ||
101 | Function: timer_get_time | ||
102 | Get the total running time. | ||
103 | |||
104 | The amount of time the timer has been stopped for is not taken | ||
105 | into account. | ||
106 | */ | ||
107 | double timer_get_time (const Timer*); | ||
108 | |||
109 | /* | ||
110 | Function: timer_get_delta | ||
111 | Get the time elapsed since the last tick, or since the start if | ||
112 | this is the first tick. | ||
113 | */ | ||
114 | float timer_get_delta (const Timer*); | ||
115 | |||
116 | /* | ||
117 | Function: timer_is_running | ||
118 | Return true if the timer is running (not stopped), false otherwise. | ||
119 | */ | ||
120 | char timer_is_running (const Timer*); | ||
121 | |||
122 | /* | ||
123 | Function: timer_sleep | ||
124 | Put the caller thread to sleep for the given number of seconds. | ||
125 | */ | ||
126 | void timer_sleep (float seconds); | ||
68 | 127 | ||
69 | #ifdef __cplusplus | 128 | #ifdef __cplusplus |
70 | } | 129 | } |
71 | #endif | 130 | #endif |
72 | |||
73 | #endif // _SPEAR_TIMER_H | ||
diff --git a/Spear/Sys/Timer/ctimer.c b/Spear/Sys/Timer/ctimer.c index 7f7ffe0..8c059c0 100644 --- a/Spear/Sys/Timer/ctimer.c +++ b/Spear/Sys/Timer/ctimer.c | |||
@@ -1,172 +1,157 @@ | |||
1 | #include "Timer.h" | 1 | #include "Timer.h" |
2 | #include <stdlib.h> | 2 | #include <stdlib.h> |
3 | 3 | ||
4 | #ifdef __APPLE__ | 4 | #ifdef __APPLE__ |
5 | #include <mach/mach_time.h> | 5 | #include <mach/mach_time.h> |
6 | #elif WIN32 | 6 | #elif WIN32 |
7 | #define WIN32_LEAN_AND_MEAN | 7 | #define WIN32_LEAN_AND_MEAN |
8 | #include <Windows.h> | 8 | #include <Windows.h> |
9 | #else // Linux | 9 | #else // Linux |
10 | #include <time.h> | 10 | #include <time.h> |
11 | const double NSEC_TO_SEC = 1.0f/1000000000.0f; | 11 | const double NSEC_TO_SEC = 1.0 / 1000000000.0; |
12 | const double SEC_TO_NSEC = 1000000000.0f; | 12 | const double SEC_TO_NSECd = 1000000000.0; |
13 | #endif | 13 | const timeReading SEC_TO_NSEC = 1000000000; |
14 | 14 | #endif | |
15 | 15 | ||
16 | static double secondsPerCount; | 16 | static double secondsPerCount; |
17 | 17 | ||
18 | 18 | static void timer_initialise_subsystem () | |
19 | void timer_initialise_subsystem () | 19 | { |
20 | { | 20 | #ifdef WIN32 |
21 | #ifdef WIN32 | 21 | __int64 countsPerSec; |
22 | __int64 countsPerSec; | 22 | QueryPerformanceFrequency((LARGE_INTEGER*)&countsPerSec); |
23 | QueryPerformanceFrequency((LARGE_INTEGER*)&countsPerSec); | 23 | secondsPerCount = 1.0 / (double)countsPerSec; |
24 | secondsPerCount = 1.0 / (double)countsPerSec; | 24 | #else |
25 | #else | 25 | struct timespec ts; |
26 | /*struct timespec ts; | 26 | clock_getres(CLOCK_REALTIME, &ts); |
27 | clock_getres(CLOCK_REALTIME, &ts); | 27 | secondsPerCount = (double)ts.tv_sec + ((double)ts.tv_nsec * NSEC_TO_SEC); |
28 | secondsPerCount = (double)ts.tv_sec + ((double)ts.tv_nsec * NSEC_TO_SEC);*/ | 28 | #endif |
29 | secondsPerCount = 1.0f; | 29 | } |
30 | #endif | 30 | |
31 | } | 31 | static timeReading now () |
32 | 32 | { | |
33 | 33 | timeReading t; | |
34 | timeReading now () | 34 | #ifdef __APPLE__ |
35 | { | 35 | t = mach_absolute_time(); |
36 | timeReading t; | 36 | #elif WIN32 |
37 | 37 | QueryPerformanceCounter((LARGE_INTEGER*)&t); | |
38 | #ifdef __APPLE__ | 38 | #else |
39 | t = mach_absolute_time(); | 39 | struct timespec ts; |
40 | #elif WIN32 | 40 | clock_gettime(CLOCK_REALTIME, &ts); |
41 | QueryPerformanceCounter((LARGE_INTEGER*)&t); | 41 | t = ts.tv_sec*SEC_TO_NSEC + ts.tv_nsec; |
42 | #else | 42 | #endif |
43 | struct timespec ts; | 43 | return t; |
44 | clock_gettime(CLOCK_REALTIME, &ts); | 44 | } |
45 | t = ts.tv_sec + ((double)ts.tv_nsec * NSEC_TO_SEC); | 45 | |
46 | #endif | 46 | void timer_init (Timer* timer) |
47 | 47 | { | |
48 | return t; | 48 | timer_initialise_subsystem(); |
49 | } | 49 | timer_reset (timer); |
50 | 50 | } | |
51 | 51 | ||
52 | void DECLDIR timer_initialise_timer (timer* t) | 52 | void timer_tick (Timer* timer) |
53 | { | 53 | { |
54 | t->baseTime = 0; | 54 | if (timer->stopped) |
55 | t->pausedTime = 0; | 55 | { |
56 | t->stopTime = 0; | 56 | timer->deltaTime = 0.0; |
57 | t->prevTime = 0; | 57 | return; |
58 | t->curTime = 0; | 58 | } |
59 | t->deltaTime = 0; | 59 | |
60 | t->stopped = 1; | 60 | //Get the time on this frame. |
61 | } | 61 | timer->curTime = now(); |
62 | 62 | ||
63 | 63 | //Time delta between the current frame and the previous. | |
64 | void timer_tick (timer* t) | 64 | timer->deltaTime = (float) ((timer->curTime - timer->prevTime) * secondsPerCount); |
65 | { | 65 | |
66 | if (t->stopped) | 66 | //Update for next frame. |
67 | { | 67 | timer->prevTime = timer->curTime; |
68 | t->deltaTime = 0.0; | 68 | |
69 | return; | 69 | // Force nonnegative. The DXSDK's CDXUTTimer mentions that if the |
70 | } | 70 | // processor goes into a power save mode or we get shuffled to |
71 | 71 | // another processor, then the delta time can be negative. | |
72 | //Get the time on this frame. | 72 | if(timer->deltaTime < 0.0f) |
73 | t->curTime = now(); | 73 | { |
74 | 74 | timer->deltaTime = 0.0f; | |
75 | //Time delta between the current frame and the previous. | 75 | } |
76 | t->deltaTime = (float) ((t->curTime - t->prevTime) * secondsPerCount); | 76 | } |
77 | 77 | ||
78 | //Update for next frame. | 78 | void timer_reset (Timer* timer) |
79 | t->prevTime = t->curTime; | 79 | { |
80 | 80 | timeReading n = now(); | |
81 | // Force nonnegative. The DXSDK's CDXUTTimer mentions that if the | 81 | timer->baseTime = n; |
82 | // processor goes into a power save mode or we get shuffled to | 82 | timer->stopTime = n; |
83 | // another processor, then mDeltaTime can be negative. | 83 | timer->prevTime = n; |
84 | if(t->deltaTime < 0.0) | 84 | timer->curTime = n; |
85 | { | 85 | timer->pausedTime = 0; |
86 | t->deltaTime = 0.0; | 86 | timer->deltaTime = 0.0f; |
87 | } | 87 | timer->stopped = 1; |
88 | } | 88 | } |
89 | 89 | ||
90 | 90 | void timer_stop (Timer* timer) | |
91 | void timer_reset (timer* t) | 91 | { |
92 | { | 92 | // Don't do anything if we are already stopped. |
93 | t->curTime = now(); | 93 | if (!timer->stopped) |
94 | t->baseTime = t->curTime; | 94 | { |
95 | t->prevTime = t->curTime; | 95 | // Grab the stop time. |
96 | t->stopTime = 0; | 96 | timer->stopTime = now(); |
97 | t->stopped = 0; | 97 | |
98 | } | 98 | // Now we are stopped. |
99 | 99 | timer->stopped = 1; | |
100 | 100 | } | |
101 | void timer_stop (timer* t) | 101 | } |
102 | { | 102 | |
103 | // Don't do anything if we are already stopped. | 103 | void timer_start (Timer* timer) |
104 | if (!t->stopped) | 104 | { |
105 | { | 105 | // Only start if we are stopped. |
106 | // Grab the stop time. | 106 | if (timer->stopped) |
107 | t->stopTime = now(); | 107 | { |
108 | 108 | timeReading startTime = now(); | |
109 | // Now we are stopped. | 109 | |
110 | t->stopped = 1; | 110 | // Accumulate the paused time. |
111 | } | 111 | timer->pausedTime = timer->pausedTime + startTime - timer->stopTime; |
112 | } | 112 | |
113 | 113 | // Make the previous time valid. | |
114 | 114 | timer->prevTime = startTime; | |
115 | void timer_start (timer* t) | 115 | |
116 | { | 116 | //Now we are running. |
117 | // Only start if we are stopped. | 117 | timer->stopTime = 0; |
118 | if (t->stopped) | 118 | timer->stopped = 0; |
119 | { | 119 | } |
120 | timeReading startTime = now(); | 120 | } |
121 | 121 | ||
122 | // Accumulate the paused time. | 122 | double timer_get_time (const Timer* timer) |
123 | t->pausedTime = t->pausedTime + startTime - t->stopTime; | 123 | { |
124 | 124 | // If we are stopped, we do not count the time we have been stopped for. | |
125 | // Make the previous time valid. | 125 | if (timer->stopped) |
126 | t->prevTime = startTime; | 126 | { |
127 | 127 | return (double)((timer->stopTime - timer->baseTime) * secondsPerCount); | |
128 | //Now we are running. | 128 | } |
129 | t->stopTime = 0; | 129 | // Otherwise return the time elapsed since the start but without |
130 | t->stopped = 0; | 130 | // taking into account the time we have been stopped for. |
131 | } | 131 | else |
132 | } | 132 | { |
133 | 133 | return (double)((timer->curTime - timer->baseTime - timer->pausedTime) * secondsPerCount); | |
134 | 134 | } | |
135 | void timer_sleep (float seconds) | 135 | } |
136 | { | 136 | |
137 | #ifdef WIN32 | 137 | float timer_get_delta (const Timer* timer) |
138 | Sleep((DWORD)(seconds * 1000)); | 138 | { |
139 | #else | 139 | return timer->deltaTime; |
140 | struct timespec ts; | 140 | } |
141 | ts.tv_sec = 0; | 141 | |
142 | ts.tv_nsec = seconds * SEC_TO_NSEC; | 142 | char timer_is_running (const Timer* timer) |
143 | nanosleep(&ts, NULL); | 143 | { |
144 | #endif | 144 | return !timer->stopped; |
145 | } | 145 | } |
146 | 146 | ||
147 | 147 | void timer_sleep (float seconds) | |
148 | float timer_get_time (timer* t) | 148 | { |
149 | { | 149 | #ifdef WIN32 |
150 | // If we are stopped, we do not count the time we have been stopped for. | 150 | Sleep((DWORD)(seconds * 1000)); |
151 | if (t->stopped) | 151 | #else |
152 | { | 152 | struct timespec ts; |
153 | return (float)((t->stopTime - t->baseTime) * secondsPerCount); | 153 | ts.tv_sec = (int) seconds; |
154 | } | 154 | ts.tv_nsec = (long) ((double)(seconds - (int)seconds) * SEC_TO_NSECd); |
155 | // Otherwise return the time elapsed since the start of the game without counting the time we have been paused for. | 155 | nanosleep(&ts, NULL); |
156 | else | 156 | #endif |
157 | { | 157 | } |
158 | return (float)((t->curTime - t->baseTime - t->pausedTime) * secondsPerCount); | ||
159 | } | ||
160 | } | ||
161 | |||
162 | |||
163 | float timer_get_delta (timer* t) | ||
164 | { | ||
165 | return t->deltaTime; | ||
166 | } | ||
167 | |||
168 | |||
169 | char timer_is_running (timer* t) | ||
170 | { | ||
171 | return !t->stopped; | ||
172 | } | ||