aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeanne-Kamikaze <jeannekamikaze@gmail.com>2013-05-10 16:10:28 +0200
committerJeanne-Kamikaze <jeannekamikaze@gmail.com>2013-05-10 16:10:28 +0200
commit7360483ecb4e783566968b9a88e0cf3d3b4bd6c0 (patch)
treee7e2cf0255a3b85c88ad7df2f762a6905f098c8b
parent4700e77c897d6ced15f1aac6d3c9513ab0265d38 (diff)
Game tweaks; fixed GLFW terminate bug
Diffstat
-rw-r--r--LICENSE14
-rw-r--r--README.md96
-rw-r--r--Setup.hs4
-rw-r--r--Spear.cabal216
-rw-r--r--Spear/App.hs20
-rw-r--r--Spear/App/Application.hs268
-rw-r--r--Spear/App/Input.hs530
-rw-r--r--Spear/Assets/Image.hsc252
-rw-r--r--Spear/Assets/Image/Image.c16
-rw-r--r--Spear/Assets/Image/Image.h64
-rw-r--r--Spear/Assets/Image/Image_error_code.h30
-rw-r--r--Spear/Assets/Image/sys_types.h32
-rw-r--r--Spear/Assets/Model.hsc880
-rw-r--r--Spear/Assets/Model/MD2/MD2_load.c960
-rw-r--r--Spear/Assets/Model/Model.c224
-rw-r--r--Spear/Assets/Model/Model.h200
-rw-r--r--Spear/Assets/Model/Model_error_code.h32
-rw-r--r--Spear/Assets/Model/OBJ/Makefile30
-rw-r--r--Spear/Assets/Model/OBJ/OBJ_load.c548
-rw-r--r--Spear/Assets/Model/OBJ/OBJ_load.h50
-rw-r--r--Spear/Assets/Model/OBJ/cvector.c180
-rw-r--r--Spear/Assets/Model/OBJ/cvector.h72
-rw-r--r--Spear/Assets/Model/sys_types.h32
-rw-r--r--Spear/GL.hs1449
-rw-r--r--Spear/Game.hs199
-rw-r--r--Spear/Math/AABB.hs80
-rw-r--r--Spear/Math/Camera.hs150
-rw-r--r--Spear/Math/Circle.hs52
-rw-r--r--Spear/Math/Collision.hs482
-rw-r--r--Spear/Math/Entity.hs66
-rw-r--r--Spear/Math/Frustum.hs56
-rw-r--r--Spear/Math/Matrix3.hs670
-rw-r--r--Spear/Math/Matrix4.hs1300
-rw-r--r--Spear/Math/MatrixUtils.hs300
-rw-r--r--Spear/Math/Octree.hs456
-rw-r--r--Spear/Math/Physics.hs18
-rw-r--r--Spear/Math/Physics/Rigid.hs250
-rw-r--r--Spear/Math/Physics/Types.hs22
-rw-r--r--Spear/Math/Plane.hs78
-rw-r--r--Spear/Math/Quaternion.hs216
-rw-r--r--Spear/Math/Ray.hs62
-rw-r--r--Spear/Math/Segment.hs42
-rw-r--r--Spear/Math/Spatial2.hs150
-rw-r--r--Spear/Math/Spatial3.hs322
-rw-r--r--Spear/Math/Sphere.hs52
-rw-r--r--Spear/Math/Triangle.hs80
-rw-r--r--Spear/Math/Utils.hs76
-rw-r--r--Spear/Math/Vector.hs26
-rw-r--r--Spear/Math/Vector/Class.hs84
-rw-r--r--Spear/Math/Vector/Vector2.hs260
-rw-r--r--Spear/Math/Vector/Vector3.hs368
-rw-r--r--Spear/Math/Vector/Vector4.hs332
-rw-r--r--Spear/Render/AnimatedModel.hs470
-rw-r--r--Spear/Render/Box.hs384
-rw-r--r--Spear/Render/Material.hs32
-rw-r--r--Spear/Render/Model.hsc108
-rw-r--r--Spear/Render/Program.hs204
-rw-r--r--Spear/Render/RenderModel.c464
-rw-r--r--Spear/Render/RenderModel.h98
-rw-r--r--Spear/Render/Sphere.hs88
-rw-r--r--Spear/Render/StaticModel.hs276
-rw-r--r--Spear/Render/Triangle.hs16
-rw-r--r--Spear/Scene/GameObject.hs640
-rw-r--r--Spear/Scene/Graph.hs286
-rw-r--r--Spear/Scene/Light.hs62
-rw-r--r--Spear/Scene/Loader.hs856
-rw-r--r--Spear/Scene/SceneResources.hs144
-rw-r--r--Spear/Sys/Store.hs390
-rw-r--r--Spear/Sys/Store/ID.hs212
-rw-r--r--Spear/Sys/Timer.hs194
-rw-r--r--Spear/Sys/Timer.hsc325
-rw-r--r--Spear/Sys/Timer/Timer.h155
-rw-r--r--Spear/Sys/Timer/ctimer.c329
73 files changed, 9017 insertions, 9164 deletions
diff --git a/LICENSE b/LICENSE
index 914c31a..037be14 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,7 +1,7 @@
1Copyright (c) 2012 Marc Sunet 1Copyright (c) 2012 Marc Sunet
2 2
3Permission 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: 3Permission 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
5The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 5The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
6 6
7THE 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. 7THE 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.
diff --git a/README.md b/README.md
index b1c470b..3724fe9 100644
--- a/README.md
+++ b/README.md
@@ -1,48 +1,48 @@
1Spear 1Spear
2===== 2=====
3 3
4Spear is a simple 2.5D game engine I have been working on since I started learning Haskell. 4Spear is a simple 2.5D game engine I have been working on since I started learning Haskell.
5The project's goal is to put what I learn into practise, to explore how far I can get with Haskell and if the results 5The project's goal is to put what I learn into practise, to explore how far I can get with Haskell and if the results
6are decent enough, to build one or two game demos along the way. 6are decent enough, to build one or two game demos along the way.
7 7
8Installation 8Installation
9------------ 9------------
10 10
11Simply clone the repo and build with cabal: 11Simply 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
19Features 19Features
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.
diff --git a/Setup.hs b/Setup.hs
index 9a994af..833b4c6 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,2 @@
1import Distribution.Simple 1import Distribution.Simple
2main = defaultMain 2main = defaultMain
diff --git a/Spear.cabal b/Spear.cabal
index e25b347..0e52faf 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -1,108 +1,108 @@
1name: Spear 1name: Spear
2version: 0.1 2version: 0.1
3cabal-version: >=1.2 3cabal-version: >=1.2
4build-type: Simple 4build-type: Simple
5license: BSD3 5license: BSD3
6license-file: LICENSE 6license-file: LICENSE
7maintainer: jeannekamikaze@gmail.com 7maintainer: jeannekamikaze@gmail.com
8homepage: http://spear.shellblade.net 8homepage: http://spear.shellblade.net
9synopsis: A 2.5D game framework. 9synopsis: A 2.5D game framework.
10category: Game 10category: Game
11author: Marc Sunet 11author: Marc Sunet
12data-dir: "" 12data-dir: ""
13 13
14library 14library
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 @@
1module Spear.App 1module 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)
6where 6where
7 7
8 8
9import Spear.App.Application 9import Spear.App.Application
10import Spear.App.Input 10import 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 @@
1module Spear.App.Application 1module 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(..) 20where
21, enableSpecial 21
22, disableSpecial 22import Spear.Game
23) 23import Spear.Sys.Timer as Timer
24where 24
25 25import Control.Concurrent.MVar
26import Spear.Game 26import Control.Monad (when)
27import Spear.Sys.Timer as Timer 27import Graphics.UI.GLFW as GLFW
28 28import Graphics.Rendering.OpenGL as GL
29import Control.Applicative 29
30import Control.Monad (forever, when) 30-- | Window dimensions.
31import Control.Monad.Trans.Error 31type Dimensions = (Int, Int)
32import Control.Monad.Trans.Class (lift) 32
33import Graphics.UI.GLFW as GLFW 33-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor).
34import Graphics.Rendering.OpenGL as GL 34type Context = (Int, Int)
35import System.Exit 35
36import Unsafe.Coerce 36type WindowTitle = String
37 37
38-- | Window dimensions. 38-- Whether the user has closed the window.
39type Dimensions = (Int, Int) 39type CloseRequested = MVar Bool
40 40
41-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). 41-- | Represents a window.
42type Context = (Int, Int) 42data SpearWindow = SpearWindow
43 43 { closeRequest :: CloseRequested
44-- | Represents a window. 44 }
45newtype SpearWindow = SpearWindow { rkey :: Resource } 45
46 46withWindow :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle
47instance ResourceClass SpearWindow where 47 -> WindowSizeCallback -> (SpearWindow -> Game s a) -> Game s a
48 getResource = rkey 48withWindow 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
51setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context 51 gs <- getGameState
52 -> WindowSizeCallback -> Game s SpearWindow 52 (a,s) <- runSubGame (run window) gs
53setup (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 59setup :: 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 61setup (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"
73glfwInit :: Game s () 73 Just title -> title
74glfwInit = 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
81quit :: IO () 81
82quit = GLFW.terminate 82glfwInit :: Game s ()
83 83glfwInit = do
84-- | Return true if the application should continue running, false otherwise. 84 result <- gameIO GLFW.initialize
85type 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 ()
88loop :: Update s -> Game s () 88
89loop update = do 89-- | Return true if the application should continue running, false otherwise.
90 timer <- gameIO $ start newTimer 90type Update s = Float -> Game s (Bool)
91 run timer update 91
92 92-- | Run the application's main loop.
93run :: Timer -> Update s -> Game s () 93loop :: SpearWindow -> Update s -> Game s ()
94run timer update = do 94loop 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 101run :: CloseRequested -> Timer -> Update s -> Game s ()
102-- | Run the application's main loop, with a limit on the frame rate. 102run closeRequest timer update = do
103loopCapped :: Int -> Update s -> Game s () 103 timer' <- gameIO $ tick timer
104loopCapped 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.
109runCapped :: Float -> Timer -> Update s -> Game s () 109loopCapped :: SpearWindow -> Int -> Update s -> Game s ()
110runCapped ddt timer update = do 110loopCapped 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 120runCapped :: CloseRequested -> Float -> Timer -> Timer -> Update s -> Game s ()
121 121runCapped closeRequest ddt frameTimer controlTimer update = do
122onResize :: WindowSizeCallback -> Size -> IO () 122 controlTimer' <- gameIO $ tick controlTimer
123onResize 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
132getRequest :: MVar Bool -> IO Bool
133getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of
134 Nothing -> False
135 Just x -> x
136
137onResize :: WindowSizeCallback -> Size -> IO ()
138onResize callback s@(Size w h) = do
139 GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h))
140 callback s
141
142onWindowClose :: MVar Bool -> WindowCloseCallback
143onWindowClose 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 @@
1module Spear.App.Input 1module 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)
31where 31where
32 32
33import Data.Char (ord) 33import Data.Char (ord)
34import qualified Data.Vector.Unboxed as V 34import qualified Data.Vector.Unboxed as V
35import qualified Graphics.UI.GLFW as GLFW 35import qualified Graphics.UI.GLFW as GLFW
36import Graphics.Rendering.OpenGL.GL.CoordTrans 36import Graphics.Rendering.OpenGL.GL.CoordTrans
37import Graphics.Rendering.OpenGL.GL.StateVar 37import Graphics.Rendering.OpenGL.GL.StateVar
38 38
39data Key 39data 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
50type Keyboard = Key -> Bool 50type Keyboard = Key -> Bool
51 51
52data MouseButton = LMB | RMB | MMB 52data MouseButton = LMB | RMB | MMB
53 deriving (Enum, Bounded) 53 deriving (Enum, Bounded)
54 54
55data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta 55data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta
56 deriving Enum 56 deriving Enum
57 57
58data Mouse = Mouse 58data Mouse = Mouse
59 { button :: MouseButton -> Bool 59 { button :: MouseButton -> Bool
60 , property :: MouseProp -> Float 60 , property :: MouseProp -> Float
61 } 61 }
62 62
63data Input = Input 63data 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'.
75newKeyboard :: Keyboard 75newKeyboard :: Keyboard
76newKeyboard = const False 76newKeyboard = const False
77 77
78-- | Get the keyboard. 78-- | Get the keyboard.
79getKeyboard :: IO Keyboard 79getKeyboard :: IO Keyboard
80getKeyboard = 80getKeyboard =
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'.
95newMouse :: Mouse 95newMouse :: Mouse
96newMouse = Mouse (const False) (const 0) 96newMouse = 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.
101getMouse :: Mouse -> IO Mouse 101getMouse :: Mouse -> IO Mouse
102getMouse oldMouse = 102getMouse 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.
134newInput :: Input 134newInput :: Input
135newInput = Input newKeyboard newMouse 135newInput = Input newKeyboard newMouse
136 136
137-- | Get input devices. 137-- | Get input devices.
138getInput :: Input -> IO Input 138getInput :: Input -> IO Input
139getInput (Input _ oldMouse) = do 139getInput (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.
145pollInput :: IO () 145pollInput :: IO ()
146pollInput = GLFW.pollEvents 146pollInput = GLFW.pollEvents
147 147
148-- | Return a mouse that reacts to button toggles. 148-- | Return a mouse that reacts to button toggles.
149toggledMouse :: Mouse -- ^ Previous mouse state. 149toggledMouse :: Mouse -- ^ Previous mouse state.
150 -> Mouse -- ^ Current mouse state. 150 -> Mouse -- ^ Current mouse state.
151 -> Mouse -- ^ Toggled mouse. 151 -> Mouse -- ^ Toggled mouse.
152 152
153toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) } 153toggledMouse 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.
156toggledKeyboard :: Keyboard -- ^ Previous keyboard state. 156toggledKeyboard :: Keyboard -- ^ Previous keyboard state.
157 -> Keyboard -- ^ Current keyboard state. 157 -> Keyboard -- ^ Current keyboard state.
158 -> Keyboard -- ^ Toggled keyboard. 158 -> Keyboard -- ^ Toggled keyboard.
159 159
160toggledKeyboard prev cur key = cur key && not (prev key) 160toggledKeyboard prev cur key = cur key && not (prev key)
161 161
162-- | Delay configuration for each mouse button. 162-- | Delay configuration for each mouse button.
163type ButtonDelay = MouseButton -> Float 163type ButtonDelay = MouseButton -> Float
164 164
165 165
166-- | Accumulated delays for each mouse button. 166-- | Accumulated delays for each mouse button.
167data DelayedMouse = DelayedMouse 167data 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
173newDM :: ButtonDelay -- ^ Delay configuration for each button. 173newDM :: ButtonDelay -- ^ Delay configuration for each button.
174 -> DelayedMouse 174 -> DelayedMouse
175newDM delay = DelayedMouse newMouse delay $ 175newDM delay = DelayedMouse newMouse delay $
176 V.replicate (fromEnum (maxBound :: MouseButton)) 0 176 V.replicate (fromEnum (maxBound :: MouseButton)) 0
177 177
178updateDM :: DelayedMouse -- ^ Current mouse state. 178updateDM :: DelayedMouse -- ^ Current mouse state.
179 -> Float -- ^ Time elapsed since last udpate. 179 -> Float -- ^ Time elapsed since last udpate.
180 -> DelayedMouse 180 -> DelayedMouse
181 181
182updateDM (DelayedMouse mouse delay accum) dt = 182updateDM (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.
194setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse 194setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse
195setMousePosition (x,y) mouse = do 195setMousePosition (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.
200setMouseWheel :: Integral a => a -> Mouse -> IO Mouse 200setMouseWheel :: Integral a => a -> Mouse -> IO Mouse
201setMouseWheel w mouse = do 201setMouseWheel w mouse = do
202 GLFW.mouseWheel $= (fromIntegral w) 202 GLFW.mouseWheel $= (fromIntegral w)
203 getMouse mouse 203 getMouse mouse
204 204
205toGLFWkey :: Key -> Int 205toGLFWkey :: Key -> Int
206toGLFWkey KEY_A = ord 'A' 206toGLFWkey KEY_A = ord 'A'
207toGLFWkey KEY_B = ord 'B' 207toGLFWkey KEY_B = ord 'B'
208toGLFWkey KEY_C = ord 'C' 208toGLFWkey KEY_C = ord 'C'
209toGLFWkey KEY_D = ord 'D' 209toGLFWkey KEY_D = ord 'D'
210toGLFWkey KEY_E = ord 'E' 210toGLFWkey KEY_E = ord 'E'
211toGLFWkey KEY_F = ord 'F' 211toGLFWkey KEY_F = ord 'F'
212toGLFWkey KEY_G = ord 'G' 212toGLFWkey KEY_G = ord 'G'
213toGLFWkey KEY_H = ord 'H' 213toGLFWkey KEY_H = ord 'H'
214toGLFWkey KEY_I = ord 'I' 214toGLFWkey KEY_I = ord 'I'
215toGLFWkey KEY_J = ord 'J' 215toGLFWkey KEY_J = ord 'J'
216toGLFWkey KEY_K = ord 'K' 216toGLFWkey KEY_K = ord 'K'
217toGLFWkey KEY_L = ord 'L' 217toGLFWkey KEY_L = ord 'L'
218toGLFWkey KEY_M = ord 'M' 218toGLFWkey KEY_M = ord 'M'
219toGLFWkey KEY_N = ord 'N' 219toGLFWkey KEY_N = ord 'N'
220toGLFWkey KEY_O = ord 'O' 220toGLFWkey KEY_O = ord 'O'
221toGLFWkey KEY_P = ord 'P' 221toGLFWkey KEY_P = ord 'P'
222toGLFWkey KEY_Q = ord 'Q' 222toGLFWkey KEY_Q = ord 'Q'
223toGLFWkey KEY_R = ord 'R' 223toGLFWkey KEY_R = ord 'R'
224toGLFWkey KEY_S = ord 'S' 224toGLFWkey KEY_S = ord 'S'
225toGLFWkey KEY_T = ord 'T' 225toGLFWkey KEY_T = ord 'T'
226toGLFWkey KEY_U = ord 'U' 226toGLFWkey KEY_U = ord 'U'
227toGLFWkey KEY_V = ord 'V' 227toGLFWkey KEY_V = ord 'V'
228toGLFWkey KEY_W = ord 'W' 228toGLFWkey KEY_W = ord 'W'
229toGLFWkey KEY_X = ord 'X' 229toGLFWkey KEY_X = ord 'X'
230toGLFWkey KEY_Y = ord 'Y' 230toGLFWkey KEY_Y = ord 'Y'
231toGLFWkey KEY_Z = ord 'Z' 231toGLFWkey KEY_Z = ord 'Z'
232toGLFWkey KEY_0 = ord '0' 232toGLFWkey KEY_0 = ord '0'
233toGLFWkey KEY_1 = ord '1' 233toGLFWkey KEY_1 = ord '1'
234toGLFWkey KEY_2 = ord '2' 234toGLFWkey KEY_2 = ord '2'
235toGLFWkey KEY_3 = ord '3' 235toGLFWkey KEY_3 = ord '3'
236toGLFWkey KEY_4 = ord '4' 236toGLFWkey KEY_4 = ord '4'
237toGLFWkey KEY_5 = ord '5' 237toGLFWkey KEY_5 = ord '5'
238toGLFWkey KEY_6 = ord '6' 238toGLFWkey KEY_6 = ord '6'
239toGLFWkey KEY_7 = ord '7' 239toGLFWkey KEY_7 = ord '7'
240toGLFWkey KEY_8 = ord '8' 240toGLFWkey KEY_8 = ord '8'
241toGLFWkey KEY_9 = ord '9' 241toGLFWkey KEY_9 = ord '9'
242toGLFWkey KEY_F1 = fromEnum GLFW.F1 242toGLFWkey KEY_F1 = fromEnum GLFW.F1
243toGLFWkey KEY_F2 = fromEnum GLFW.F2 243toGLFWkey KEY_F2 = fromEnum GLFW.F2
244toGLFWkey KEY_F3 = fromEnum GLFW.F3 244toGLFWkey KEY_F3 = fromEnum GLFW.F3
245toGLFWkey KEY_F4 = fromEnum GLFW.F4 245toGLFWkey KEY_F4 = fromEnum GLFW.F4
246toGLFWkey KEY_F5 = fromEnum GLFW.F5 246toGLFWkey KEY_F5 = fromEnum GLFW.F5
247toGLFWkey KEY_F6 = fromEnum GLFW.F6 247toGLFWkey KEY_F6 = fromEnum GLFW.F6
248toGLFWkey KEY_F7 = fromEnum GLFW.F7 248toGLFWkey KEY_F7 = fromEnum GLFW.F7
249toGLFWkey KEY_F8 = fromEnum GLFW.F8 249toGLFWkey KEY_F8 = fromEnum GLFW.F8
250toGLFWkey KEY_F9 = fromEnum GLFW.F9 250toGLFWkey KEY_F9 = fromEnum GLFW.F9
251toGLFWkey KEY_F10 = fromEnum GLFW.F10 251toGLFWkey KEY_F10 = fromEnum GLFW.F10
252toGLFWkey KEY_F11 = fromEnum GLFW.F11 252toGLFWkey KEY_F11 = fromEnum GLFW.F11
253toGLFWkey KEY_F12 = fromEnum GLFW.F12 253toGLFWkey KEY_F12 = fromEnum GLFW.F12
254toGLFWkey KEY_ESC = fromEnum GLFW.ESC 254toGLFWkey KEY_ESC = fromEnum GLFW.ESC
255toGLFWkey KEY_SPACE = ord ' ' 255toGLFWkey KEY_SPACE = ord ' '
256toGLFWkey KEY_UP = fromEnum GLFW.UP 256toGLFWkey KEY_UP = fromEnum GLFW.UP
257toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN 257toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN
258toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT 258toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT
259toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT 259toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT
260 260
261 261
262toGLFWbutton :: MouseButton -> GLFW.MouseButton 262toGLFWbutton :: MouseButton -> GLFW.MouseButton
263toGLFWbutton LMB = GLFW.ButtonLeft 263toGLFWbutton LMB = GLFW.ButtonLeft
264toGLFWbutton RMB = GLFW.ButtonRight 264toGLFWbutton RMB = GLFW.ButtonRight
265toGLFWbutton MMB = GLFW.ButtonMiddle 265toGLFWbutton 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
3module Spear.Assets.Image 3module 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)
15where 15where
16 16
17import Spear.Game 17import Spear.Game
18import Foreign.Ptr 18import Foreign.Ptr
19import Foreign.Storable 19import Foreign.Storable
20import Foreign.C.Types 20import Foreign.C.Types
21import Foreign.C.String 21import Foreign.C.String
22import Foreign.Marshal.Utils as Foreign (with) 22import Foreign.Marshal.Utils as Foreign (with)
23import Foreign.Marshal.Alloc (alloca) 23import Foreign.Marshal.Alloc (alloca)
24import Data.List (splitAt, elemIndex) 24import Data.List (splitAt, elemIndex)
25import Data.Char (toLower) 25import 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
30data ImageErrorCode 30data 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
39data CImage = CImage 39data 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
46instance Storable CImage where 46instance 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'.
64data Image = Image 64data Image = Image
65 { imageData :: CImage 65 { imageData :: CImage
66 , rkey :: Resource 66 , rkey :: Resource
67 } 67 }
68 68
69instance ResourceClass Image where 69instance ResourceClass Image where
70 getResource = rkey 70 getResource = rkey
71 71
72foreign import ccall "Image.h image_free" 72foreign import ccall "Image.h image_free"
73 image_free :: Ptr CImage -> IO () 73 image_free :: Ptr CImage -> IO ()
74 74
75foreign import ccall "BMP_load.h BMP_load" 75foreign 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
78bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode 78bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode
79bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code 79bmp_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.
82loadImage :: FilePath -> Game s Image 82loadImage :: FilePath -> Game s Image
83loadImage file = do 83loadImage 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'.
109freeImage :: CImage -> IO () 109freeImage :: CImage -> IO ()
110freeImage image = Foreign.with image image_free 110freeImage image = Foreign.with image image_free
111 111
112-- | Return the given image's width. 112-- | Return the given image's width.
113width :: Image -> Int 113width :: Image -> Int
114width = fromIntegral . cwidth . imageData 114width = fromIntegral . cwidth . imageData
115 115
116-- | Return the given image's height. 116-- | Return the given image's height.
117height :: Image -> Int 117height :: Image -> Int
118height = fromIntegral . cheight . imageData 118height = fromIntegral . cheight . imageData
119 119
120-- | Return the given image's bits per pixel. 120-- | Return the given image's bits per pixel.
121bpp :: Image -> Int 121bpp :: Image -> Int
122bpp = fromIntegral . cbpp . imageData 122bpp = fromIntegral . cbpp . imageData
123 123
124-- | Return the given image's pixels. 124-- | Return the given image's pixels.
125pixels :: Image -> Ptr CUChar 125pixels :: Image -> Ptr CUChar
126pixels = cpixels . imageData 126pixels = 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
5void image_free (Image* image) 5void 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
7typedef struct 7typedef 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}
16Image; 16Image;
17 17
18 18
19#ifdef __cplusplus 19#ifdef __cplusplus
20extern "C" { 20extern "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.
25void image_free (Image* image); 25void 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
4typedef enum 4typedef 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}
13Image_error_code; 13Image_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
6typedef int8_t I8; 6typedef int8_t I8;
7typedef int16_t I16; 7typedef int16_t I16;
8typedef int32_t I32; 8typedef int32_t I32;
9typedef int64_t I64; 9typedef int64_t I64;
10typedef uint8_t U8; 10typedef uint8_t U8;
11typedef uint16_t U16; 11typedef uint16_t U16;
12typedef uint32_t U32; 12typedef uint32_t U32;
13typedef uint64_t U64; 13typedef 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
3module Spear.Assets.Model 3module 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)
28where 28where
29 29
30import Spear.Game 30import Spear.Game
31 31
32import qualified Data.ByteString.Char8 as B 32import qualified Data.ByteString.Char8 as B
33import Data.Char (toLower) 33import Data.Char (toLower)
34import Data.List (splitAt, elemIndex) 34import Data.List (splitAt, elemIndex)
35import qualified Data.Vector as V 35import qualified Data.Vector as V
36import qualified Data.Vector.Storable as S 36import qualified Data.Vector.Storable as S
37import Foreign.Ptr 37import Foreign.Ptr
38import Foreign.Storable 38import Foreign.Storable
39import Foreign.C.Types 39import Foreign.C.Types
40import Foreign.C.String 40import Foreign.C.String
41import Foreign.Marshal.Utils as Foreign (with) 41import Foreign.Marshal.Utils as Foreign (with)
42import Foreign.Marshal.Alloc (alloca, allocaBytes) 42import Foreign.Marshal.Alloc (alloca, allocaBytes)
43import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) 43import Foreign.Marshal.Array (allocaArray, copyArray, peekArray)
44import Unsafe.Coerce (unsafeCoerce) 44import 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
50data ModelErrorCode 50data 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
59sizeFloat = #{size float} 59sizeFloat = #{size float}
60sizePtr = #{size int*} 60sizePtr = #{size int*}
61 61
62-- | A 2D vector. 62-- | A 2D vector.
63data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float 63data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float
64 64
65instance Storable Vec2 where 65instance 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.
79data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float 79data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float
80 80
81instance Storable Vec3 where 81instance 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.
97data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float 97data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float
98 98
99instance Storable TexCoord where 99instance 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.
113data CTriangle = CTriangle 113data 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
122instance Storable CTriangle where 122instance 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.
147data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 147data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3
148 148
149instance Storable Box where 149instance 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.
171newtype Skin = Skin { skinName :: B.ByteString } 171newtype Skin = Skin { skinName :: B.ByteString }
172 172
173instance Storable Skin where 173instance 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'.
187data Animation = Animation 187data 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
193instance Storable Animation where 193instance 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.
209data Model = Model 209data 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
224instance Storable Model where 224instance 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''.
276data Triangle = Triangle 276data 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
288instance Storable Triangle where 288instance 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
315foreign import ccall "Model.h model_free" 315foreign import ccall "Model.h model_free"
316 model_free :: Ptr Model -> IO () 316 model_free :: Ptr Model -> IO ()
317 317
318foreign import ccall "MD2_load.h MD2_load" 318foreign 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
321foreign import ccall "OBJ_load.h OBJ_load" 321foreign 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
324md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode 324md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode
325md2_load file clockwise leftHanded model = 325md2_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
328obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode 328obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode
329obj_load file clockwise leftHanded model = 329obj_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.
333loadModel :: FilePath -> Game s Model 333loadModel :: FilePath -> Game s Model
334loadModel file = do 334loadModel 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.
364animated :: Model -> Bool 364animated :: Model -> Bool
365animated = (>1) . numFrames 365animated = (>1) . numFrames
366 366
367-- | Return the model's ith animation. 367-- | Return the model's ith animation.
368animation :: Model -> Int -> Animation 368animation :: Model -> Int -> Animation
369animation model i = animations model S.! i 369animation 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.
372animationByName :: Model -> String -> Maybe Animation 372animationByName :: Model -> String -> Maybe Animation
373animationByName model anim = 373animationByName 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.
377triangles' :: Model -> IO [Triangle] 377triangles' :: Model -> IO [Triangle]
378triangles' model = 378triangles' 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
386foreign import ccall "Model.h model_copy_triangles" 386foreign 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.
390transformVerts :: Model -> (Vec3 -> Vec3) -> Model 390transformVerts :: Model -> (Vec3 -> Vec3) -> Model
391transformVerts model f = model { vertices = vertices' } 391transformVerts 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.
398transformNormals :: Model -> (Vec3 -> Vec3) -> Model 398transformNormals :: Model -> (Vec3 -> Vec3) -> Model
399transformNormals model f = model { normals = normals' } 399transformNormals 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.
406toGround :: Model -> IO Model 406toGround :: Model -> IO Model
407toGround model = 407toGround 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
413foreign import ccall "Model.h model_to_ground" 413foreign 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.
417modelBoxes :: Model -> IO (V.Vector Box) 417modelBoxes :: Model -> IO (V.Vector Box)
418modelBoxes model = 418modelBoxes 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
439foreign import ccall "Model.h model_compute_boxes" 439foreign 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.
19typedef struct 19typedef 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}
39md2Header_t; 39md2Header_t;
40 40
41 41
42/// Represents a texture coordinate index. 42/// Represents a texture coordinate index.
43typedef struct 43typedef struct
44{ 44{
45 I16 s; 45 I16 s;
46 I16 t; 46 I16 t;
47} 47}
48texCoord_t; 48texCoord_t;
49 49
50 50
51/// Represents a frame point. 51/// Represents a frame point.
52typedef struct 52typedef struct
53{ 53{
54 U8 x, y, z; 54 U8 x, y, z;
55 U8 lightNormalIndex; 55 U8 lightNormalIndex;
56} 56}
57vertex_t; 57vertex_t;
58 58
59 59
60/// Represents a single frame. 60/// Represents a single frame.
61typedef struct 61typedef 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}
68frame_t; 68frame_t;
69 69
70 70
71static void normalise (vec3* v) 71static 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
84static void cross (const vec3* a, const vec3* b, vec3* c) 84static 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
92static void vec3_sub (const vec3* a, const vec3* b, vec3* out) 92static 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
100static void normal (char clockwise, const vec3* p1, const vec3* p2, const vec3* p3, vec3* n) 100static 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
118typedef struct 118typedef 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}
124normal_map; 124normal_map;
125 125
126 126
127static void normal_map_initialise (normal_map* m, unsigned int N) 127static 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
133static void normal_map_clear (normal_map* m, vec3* normals, vec3* base) 133static 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
141static void normal_map_insert (normal_map* m, vec3* vec, vec3 normal) 141static 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
151static void compute_normals (normal_map* m, char left_handed) 151static 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
169static void safe_free (void* ptr) 169static void safe_free (void* ptr)
170{ 170{
171 if (ptr) free (ptr); 171 if (ptr) free (ptr);
172} 172}
173 173
174 174
175static char frame_equal (const char* name1, const char* name2) 175static 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
203static void animation_remove_numbers (char* name) 203static 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
216Model_error_code MD2_load (const char* filename, char clockwise, char left_handed, Model* model) 216Model_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
9static void safe_free (void* ptr) 9static 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
19void model_free (Model* model) 19void 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
30void model_to_ground (Model* model) 30void 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
56void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris) 56void 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
84void model_compute_boxes (Model* model, float* points) 84void 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
7typedef struct 7typedef struct
8{ 8{
9 char name[64]; 9 char name[64];
10} 10}
11skin; 11skin;
12 12
13 13
14typedef struct 14typedef struct
15{ 15{
16 float x, y, z; 16 float x, y, z;
17} 17}
18vec3; 18vec3;
19 19
20 20
21typedef struct 21typedef struct
22{ 22{
23 float s, t; 23 float s, t;
24} 24}
25texCoord; 25texCoord;
26 26
27 27
28typedef struct 28typedef struct
29{ 29{
30 U16 vertexIndices[3]; 30 U16 vertexIndices[3];
31 U16 textureIndices[3]; 31 U16 textureIndices[3];
32} 32}
33triangle; 33triangle;
34 34
35 35
36typedef struct 36typedef 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}
42animation; 42animation;
43 43
44 44
45typedef struct 45typedef 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}
61Model; 61Model;
62 62
63 63
64typedef struct 64typedef 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}
76model_triangle; 76model_triangle;
77 77
78 78
79#ifdef __cplusplus 79#ifdef __cplusplus
80extern "C" { 80extern "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.
85void model_free (Model* model); 85void 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.
88void model_to_ground (Model* model); 88void 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.
91void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris); 91void 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.
94void model_compute_boxes (Model* model, float* points); 94void 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
4typedef enum 4typedef 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}
13Model_error_code; 13Model_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 @@
1test: ../Model.o OBJ_load.o cvector.o test.o 1test: ../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
4vector: cvector.o vector-test.o 4vector: 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
12clean: 12clean:
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
9char lastError [128]; 9char lastError [128];
10 10
11 11
12static void safe_free (void* ptr) 12static 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
22static void cross (vec3 a, vec3 b, vec3* c) 22static 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
30static void vec3_sub (vec3 a, vec3 b, vec3* out) 30static 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
38static void compute_normal (char clockwise, vec3 p1, vec3 p2, vec3 p3, vec3* n) 38static 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
55static void normalise (vec3* v) 55static 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
68static void vec3_add (vec3 a, vec3* b) 68static 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
76static void read_vertex (FILE* file, vec3* vert) 76static 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
83static void read_normal (FILE* file, vec3* normal) 83static 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
89static void read_tex_coord (FILE* file, texCoord* texc) 89static 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
95static void read_face (FILE* file, 95static 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
169Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model) 169Model_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
9extern "C" { 9extern "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.
15Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model); 15Model_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.
18char* get_last_error (); 18char* 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
6int max (int a, int b) 6int 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
13int vector_new (vector* v, int elem_size, int num_elems) 13int 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
33void vector_free (vector* v) 33void 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
39void vector_initialise (vector* v, void* value) 39void 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
54int vector_append (vector* v, void* elem) 54int 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
75void* vector_ith (vector* v, int i) 75void* 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
81int vector_size (vector* v) 81int 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
87int vector_capacity (vector* v) 87int 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
4typedef struct 4typedef 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}
11vector; 11vector;
12 12
13/// Construct a new vector. 13/// Construct a new vector.
14/// Returns non-zero on error. 14/// Returns non-zero on error.
15int vector_new (vector* v, int elem_size, int num_elems); 15int vector_new (vector* v, int elem_size, int num_elems);
16 16
17/// Free the vector. 17/// Free the vector.
18void vector_free (vector* v); 18void vector_free (vector* v);
19 19
20/// Initialise every position to the given value. 20/// Initialise every position to the given value.
21void vector_initialise (vector* v, void* value); 21void 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.
25int vector_append (vector* v, void* elem); 25int vector_append (vector* v, void* elem);
26 26
27/// Access the ith element. 27/// Access the ith element.
28void* vector_ith (vector* v, int i); 28void* 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.
31int vector_size (vector* v); 31int vector_size (vector* v);
32 32
33/// Return the vector's capacity. 33/// Return the vector's capacity.
34int vector_capacity (vector* v); 34int 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
6typedef int8_t I8; 6typedef int8_t I8;
7typedef int16_t I16; 7typedef int16_t I16;
8typedef int32_t I32; 8typedef int32_t I32;
9typedef int64_t I64; 9typedef int64_t I64;
10typedef uint8_t U8; 10typedef uint8_t U8;
11typedef uint16_t U16; 11typedef uint16_t U16;
12typedef uint32_t U32; 12typedef uint32_t U32;
13typedef uint64_t U64; 13typedef 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 #-}
2module Spear.GL 2module 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)
75where 75where
76 76
77import Spear.Assets.Image 77import Spear.Assets.Image
78import Spear.Game 78import Spear.Game
79import Spear.Math.Matrix3 (Matrix3) 79import Spear.Math.Matrix3 (Matrix3)
80import Spear.Math.Matrix4 (Matrix4) 80import Spear.Math.Matrix4 (Matrix4)
81import Spear.Math.Vector 81import Spear.Math.Vector
82 82
83import Control.Monad 83import Control.Monad
84import Control.Monad.Trans.Class 84import Control.Monad.Trans.Class
85import Control.Monad.Trans.Error 85import Control.Monad.Trans.Error
86import Control.Monad.Trans.State as State 86import Control.Monad.Trans.State as State
87import qualified Data.ByteString.Char8 as B 87import qualified Data.ByteString.Char8 as B
88import Data.StateVar 88import Data.StateVar
89import Data.Word 89import Data.Word
90import Foreign.C.String 90import Foreign.C.String
91import Foreign.C.Types 91import Foreign.C.Types
92import Foreign.Ptr 92import Foreign.Ptr
93import Foreign.Storable 93import Foreign.Storable
94import Foreign.Marshal.Utils as Foreign (with) 94import Foreign.Marshal.Utils as Foreign (with)
95import Foreign.Marshal.Alloc (alloca) 95import Foreign.Marshal.Alloc (alloca)
96import Foreign.Marshal.Array (withArray) 96import Foreign.Marshal.Array (withArray)
97import Foreign.Storable (peek) 97import Foreign.Storable (peek)
98import Graphics.Rendering.OpenGL.Raw.Core32 98import Graphics.Rendering.OpenGL.Raw.Core32
99import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) 99import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory)
100import System.IO (hPutStrLn, stderr) 100import System.IO (hPutStrLn, stderr)
101import Unsafe.Coerce 101import Unsafe.Coerce
102 102
103-- 103--
104-- MANAGEMENT 104-- MANAGEMENT
105-- 105--
106 106
107-- | A GLSL shader handle. 107-- | A GLSL shader handle.
108data GLSLShader = GLSLShader 108data GLSLShader = GLSLShader
109 { getShader :: GLuint 109 { getShader :: GLuint
110 , getShaderKey :: Resource 110 , getShaderKey :: Resource
111 } 111 }
112 112
113instance ResourceClass GLSLShader where 113instance ResourceClass GLSLShader where
114 getResource = getShaderKey 114 getResource = getShaderKey
115 115
116-- | A GLSL program handle. 116-- | A GLSL program handle.
117data GLSLProgram = GLSLProgram 117data GLSLProgram = GLSLProgram
118 { getProgram :: GLuint 118 { getProgram :: GLuint
119 , getProgramKey :: Resource 119 , getProgramKey :: Resource
120 } 120 }
121 121
122instance ResourceClass GLSLProgram where 122instance ResourceClass GLSLProgram where
123 getResource = getProgramKey 123 getResource = getProgramKey
124 124
125-- | Supported shader types. 125-- | Supported shader types.
126data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) 126data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show)
127 127
128toGLShader :: ShaderType -> GLenum 128toGLShader :: ShaderType -> GLenum
129toGLShader VertexShader = gl_VERTEX_SHADER 129toGLShader VertexShader = gl_VERTEX_SHADER
130toGLShader FragmentShader = gl_FRAGMENT_SHADER 130toGLShader FragmentShader = gl_FRAGMENT_SHADER
131toGLShader GeometryShader = gl_GEOMETRY_SHADER 131toGLShader 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.
134withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a 134withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a
135withGLSLProgram prog f = f $ getProgram prog 135withGLSLProgram 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.
138uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint 138uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
139uniformLocation prog var = makeGettableStateVar $ 139uniformLocation 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.
143fragLocation :: GLSLProgram -> String -> StateVar GLint 143fragLocation :: GLSLProgram -> String -> StateVar GLint
144fragLocation prog var = makeStateVar get set 144fragLocation 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.
151attribLocation :: GLSLProgram -> String -> StateVar GLint 151attribLocation :: GLSLProgram -> String -> StateVar GLint
152attribLocation prog var = makeStateVar get set 152attribLocation 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.
159newProgram :: [GLSLShader] -> Game s GLSLProgram 159newProgram :: [GLSLShader] -> Game s GLSLProgram
160newProgram shaders = do 160newProgram 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.
170deleteProgram :: GLuint -> IO () 170deleteProgram :: GLuint -> IO ()
171--deleteProgram = glDeleteProgram 171--deleteProgram = glDeleteProgram
172deleteProgram prog = do 172deleteProgram 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.
177linkProgram :: GLSLProgram -> Game s () 177linkProgram :: GLSLProgram -> Game s ()
178linkProgram prog = do 178linkProgram 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.
194useProgram :: GLSLProgram -> IO () 194useProgram :: GLSLProgram -> IO ()
195useProgram prog = glUseProgram $ getProgram prog 195useProgram prog = glUseProgram $ getProgram prog
196 196
197-- | Deactivate the active program. 197-- | Deactivate the active program.
198unuseProgram :: IO () 198unuseProgram :: IO ()
199unuseProgram = glUseProgram 0 199unuseProgram = glUseProgram 0
200 200
201-- | Attach the given shader to the given program. 201-- | Attach the given shader to the given program.
202attachShader :: GLSLProgram -> GLSLShader -> IO () 202attachShader :: GLSLProgram -> GLSLShader -> IO ()
203attachShader prog shader = glAttachShader (getProgram prog) (getShader shader) 203attachShader 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.
206detachShader :: GLSLProgram -> GLSLShader -> IO () 206detachShader :: GLSLProgram -> GLSLShader -> IO ()
207detachShader prog shader = glDetachShader (getProgram prog) (getShader shader) 207detachShader 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'.
213loadShader :: ShaderType -> FilePath -> Game s GLSLShader 213loadShader :: ShaderType -> FilePath -> Game s GLSLShader
214loadShader shaderType file = do 214loadShader 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.
221newShader :: ShaderType -> Game s GLSLShader 221newShader :: ShaderType -> Game s GLSLShader
222newShader shaderType = do 222newShader 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.
231deleteShader :: GLuint -> IO () 231deleteShader :: GLuint -> IO ()
232--deleteShader = glDeleteShader 232--deleteShader = glDeleteShader
233deleteShader shader = do 233deleteShader 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.
239loadSource :: FilePath -> GLSLShader -> Game s () 239loadSource :: FilePath -> GLSLShader -> Game s ()
240loadSource file h = do 240loadSource 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.
249shaderSource :: GLSLShader -> CString -> IO () 249shaderSource :: GLSLShader -> CString -> IO ()
250shaderSource shader str = 250shaderSource 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.
255compile :: FilePath -> GLSLShader -> Game s () 255compile :: FilePath -> GLSLShader -> Game s ()
256compile file shader = do 256compile 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
274type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () 274type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
275type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () 275type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
276 276
277getStatus :: StatusCall -> LogCall -> GLuint -> IO String 277getStatus :: StatusCall -> LogCall -> GLuint -> IO String
278getStatus getStatus getLog h = do 278getStatus 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
286getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String 286getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String
287getErrorString getLog h len str = do 287getErrorString 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.
296readSource :: FilePath -> IO String 296readSource :: FilePath -> IO String
297readSource = fmap B.unpack . readSource' 297readSource = fmap B.unpack . readSource'
298 298
299readSource' :: FilePath -> IO B.ByteString 299readSource' :: FilePath -> IO B.ByteString
300readSource' file = do 300readSource' 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
326class Uniform a where 326class 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
330instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) 330instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a)
331instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a) 331instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a)
332 332instance Uniform CFloat where uniform loc a = glUniform1f loc a
333instance Uniform (Int,Int) where 333
334 uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y) 334instance Uniform (Int,Int) where
335 335 uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y)
336instance Uniform (Float,Float) where 336
337 uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y) 337instance Uniform (Float,Float) where
338 338 uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y)
339instance Uniform (Int,Int,Int) where 339
340 uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z) 340instance Uniform (Int,Int,Int) where
341 341 uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z)
342instance Uniform (Float,Float,Float) where 342
343 uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) 343instance Uniform (Float,Float,Float) where
344 344 uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z)
345instance Uniform (Int,Int,Int,Int) where 345
346 uniform loc (x,y,z,w) = glUniform4i loc 346instance 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)
349instance Uniform (Float,Float,Float,Float) where 349
350 uniform loc (x,y,z,w) = glUniform4f loc 350instance 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)
353instance Uniform Vector2 where 353
354 uniform loc v = glUniform2f loc x' y' 354instance 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
358instance Uniform Vector3 where 358
359 uniform loc v = glUniform3f loc x' y' z' 359instance 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
364instance Uniform Vector4 where 364
365 uniform loc v = glUniform4f loc x' y' z' w' 365instance 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
371instance Uniform Matrix3 where 371
372 uniform loc mat = 372instance 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)
376instance Uniform Matrix4 where 376
377 uniform loc mat = 377instance 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)
381instance Uniform [Float] where 381
382 uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr -> 382instance 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
389instance Uniform [Int] where 389
390 uniform loc vals = withArray (map fromIntegral vals) $ \ptr -> 390instance 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 398instance 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
402data 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--
407instance ResourceClass VAO where 407-- VAOs
408 getResource = vaoKey 408--
409 409
410instance Eq VAO where 410-- | A vertex array object.
411 vao1 == vao2 = getVAO vao1 == getVAO vao2 411data VAO = VAO
412 412 { getVAO :: GLuint
413instance Ord VAO where 413 , vaoKey :: Resource
414 vao1 < vao2 = getVAO vao1 < getVAO vao2 414 }
415 415
416-- | Create a new vao. 416instance ResourceClass VAO where
417newVAO :: Game s VAO 417 getResource = vaoKey
418newVAO = do 418
419 h <- gameIO . alloca $ \ptr -> do 419instance Eq VAO where
420 glGenVertexArrays 1 ptr 420 vao1 == vao2 = getVAO vao1 == getVAO vao2
421 peek ptr 421
422 422instance 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. 426newVAO :: Game s VAO
427deleteVAO :: GLuint -> IO () 427newVAO = do
428deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 428 h <- gameIO . alloca $ \ptr -> do
429 429 glGenVertexArrays 1 ptr
430-- | Bind the vao. 430 peek ptr
431bindVAO :: VAO -> IO () 431
432bindVAO = glBindVertexArray . getVAO 432 rkey <- register $ deleteVAO h
433 433 return $ VAO h rkey
434-- | Unbind the bound vao. 434
435unbindVAO :: IO () 435-- | Delete the vao.
436unbindVAO = glBindVertexArray 0 436deleteVAO :: GLuint -> IO ()
437 437deleteVAO 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'. 440bindVAO :: VAO -> IO ()
441enableVAOAttrib :: GLuint -- ^ Attribute index. 441bindVAO = glBindVertexArray . getVAO
442 -> IO () 442
443enableVAOAttrib = glEnableVertexAttribArray 443-- | Unbind the bound vao.
444 444unbindVAO :: IO ()
445-- | Bind the bound buffer to the given point. 445unbindVAO = glBindVertexArray 0
446attribVAOPointer 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. 450enableVAOAttrib :: 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. 452enableVAOAttrib = glEnableVertexAttribArray
453 -> IO () 453
454attribVAOPointer idx ncomp dattype normalise stride off = 454-- | Bind the bound buffer to the given point.
455 glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off) 455attribVAOPointer
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.
459drawArrays 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 () 463attribVAOPointer idx ncomp dattype normalise stride off =
464drawArrays 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
467drawElements 467-- | Draw the bound vao.
468 :: GLenum -- ^ The kind of primitives to render. 468drawArrays
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 ()
473drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs 473drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count)
474 474
475-- 475-- | Draw the bound vao, indexed mode.
476-- BUFFER 476drawElements
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.
480data 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 482drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
483 } 483
484 484--
485instance ResourceClass GLBuffer where 485-- BUFFER
486 getResource = rkey 486--
487 487
488-- | The type of target buffer. 488-- | An OpenGL buffer.
489data TargetBuffer 489data GLBuffer = GLBuffer
490 = ArrayBuffer 490 { getBuffer :: GLuint
491 | ElementArrayBuffer 491 , rkey :: Resource
492 | PixelPackBuffer 492 }
493 | PixelUnpackBuffer 493
494 deriving (Eq, Show) 494instance ResourceClass GLBuffer where
495 495 getResource = rkey
496fromTarget :: TargetBuffer -> GLenum 496
497fromTarget ArrayBuffer = gl_ARRAY_BUFFER 497-- | The type of target buffer.
498fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER 498data TargetBuffer
499fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER 499 = ArrayBuffer
500fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER 500 | ElementArrayBuffer
501 501 | PixelPackBuffer
502-- | A buffer usage. 502 | PixelUnpackBuffer
503data BufferUsage 503 deriving (Eq, Show)
504 = StreamDraw 504
505 | StreamRead 505fromTarget :: TargetBuffer -> GLenum
506 | StreamCopy 506fromTarget ArrayBuffer = gl_ARRAY_BUFFER
507 | StaticDraw 507fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER
508 | StaticRead 508fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER
509 | StaticCopy 509fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER
510 | DynamicDraw 510
511 | DynamicRead 511-- | A buffer usage.
512 | DynamicCopy 512data BufferUsage
513 deriving (Eq, Show) 513 = StreamDraw
514 514 | StreamRead
515fromUsage :: BufferUsage -> GLenum 515 | StreamCopy
516fromUsage StreamDraw = gl_STREAM_DRAW 516 | StaticDraw
517fromUsage StreamRead = gl_STREAM_READ 517 | StaticRead
518fromUsage StreamCopy = gl_STREAM_COPY 518 | StaticCopy
519fromUsage StaticDraw = gl_STATIC_DRAW 519 | DynamicDraw
520fromUsage StaticRead = gl_STATIC_READ 520 | DynamicRead
521fromUsage StaticCopy = gl_STATIC_COPY 521 | DynamicCopy
522fromUsage DynamicDraw = gl_DYNAMIC_DRAW 522 deriving (Eq, Show)
523fromUsage DynamicRead = gl_DYNAMIC_READ 523
524fromUsage DynamicCopy = gl_DYNAMIC_COPY 524fromUsage :: BufferUsage -> GLenum
525 525fromUsage StreamDraw = gl_STREAM_DRAW
526-- | Create a new buffer. 526fromUsage StreamRead = gl_STREAM_READ
527newBuffer :: Game s GLBuffer 527fromUsage StreamCopy = gl_STREAM_COPY
528newBuffer = do 528fromUsage StaticDraw = gl_STATIC_DRAW
529 h <- gameIO . alloca $ \ptr -> do 529fromUsage StaticRead = gl_STATIC_READ
530 glGenBuffers 1 ptr 530fromUsage StaticCopy = gl_STATIC_COPY
531 peek ptr 531fromUsage DynamicDraw = gl_DYNAMIC_DRAW
532 532fromUsage DynamicRead = gl_DYNAMIC_READ
533 rkey <- register $ deleteBuffer h 533fromUsage DynamicCopy = gl_DYNAMIC_COPY
534 return $ GLBuffer h rkey 534
535 535-- | Create a new buffer.
536-- | Delete the buffer. 536newBuffer :: Game s GLBuffer
537deleteBuffer :: GLuint -> IO () 537newBuffer = do
538deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 538 h <- gameIO . alloca $ \ptr -> do
539 539 glGenBuffers 1 ptr
540-- | Bind the buffer. 540 peek ptr
541bindBuffer :: GLBuffer -> TargetBuffer -> IO () 541
542bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf 542 rkey <- register $ deleteBuffer h
543 543 return $ GLBuffer h rkey
544-- | Unbind the bound buffer. 544
545unbindBuffer :: TargetBuffer -> IO () 545-- | Delete the buffer.
546unbindBuffer target = glBindBuffer (fromTarget target) 0 546deleteBuffer :: GLuint -> IO ()
547 547deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1
548class Storable a => BufferData a where 548
549 -- | Set the buffer's data. 549-- | Bind the buffer.
550 bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO () 550bindBuffer :: TargetBuffer -> GLBuffer -> IO ()
551 bufferData tgt vals usage = 551bindBuffer 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 554unbindBuffer :: TargetBuffer -> IO ()
555instance BufferData Word8 555unbindBuffer target = glBindBuffer (fromTarget target) 0
556instance BufferData Word16 556
557instance BufferData Word32 557class Storable a => BufferData a where
558instance BufferData CChar 558 -- | Set the buffer's data.
559instance BufferData CInt 559 bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO ()
560instance BufferData CFloat 560 bufferData tgt vals usage =
561instance BufferData CDouble 561 let n = sizeOf (head vals) * length vals
562instance BufferData Int 562 in withArray vals $ \ptr -> bufferData' tgt n ptr usage
563instance BufferData Float 563
564instance BufferData Double 564instance BufferData Word8
565 565instance BufferData Word16
566{-bufferData :: Storable a 566instance BufferData Word32
567 => TargetBuffer 567instance BufferData CChar
568 -> Int -- ^ The size in bytes of an element in the data list. 568instance BufferData CInt
569 -> [a] -- ^ The data list. 569instance BufferData CFloat
570 -> BufferUsage 570instance BufferData CDouble
571 -> IO () 571instance BufferData Int
572bufferData target n bufData usage = withArray bufData $ 572instance BufferData Float
573 \ptr -> bufferData target (n * length bufData) ptr usage-} 573instance BufferData Double
574 574
575-- | Set the buffer's data. 575{-bufferData :: Storable a
576bufferData' :: 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 ()
581bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) 581bufferData 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
584withGLBuffer :: GLBuffer -> (GLuint -> a) -> a 584-- | Set the buffer's data.
585withGLBuffer buf f = f $ getBuffer buf 585bufferData' :: TargetBuffer
586 586 -> Int -- ^ Buffer size in bytes.
587-- 587 -> Ptr a
588-- TEXTURE 588 -> BufferUsage
589-- 589 -> IO ()
590 590bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
591-- | Represents a texture resource. 591
592data Texture = Texture 592-- | Apply the given function the buffer's id.
593 { getTex :: GLuint 593withGLBuffer :: GLBuffer -> (GLuint -> a) -> a
594 , texKey :: Resource 594withGLBuffer buf f = f $ getBuffer buf
595 } 595
596 596--
597instance Eq Texture where 597-- TEXTURE
598 t1 == t2 = getTex t1 == getTex t2 598--
599 599
600instance Ord Texture where 600-- | Represents a texture resource.
601 t1 < t2 = getTex t1 < getTex t2 601data Texture = Texture
602 602 { getTex :: GLuint
603instance ResourceClass Texture where 603 , texKey :: Resource
604 getResource = texKey 604 }
605 605
606-- | Create a new texture. 606instance Eq Texture where
607newTexture :: Game s Texture 607 t1 == t2 = getTex t1 == getTex t2
608newTexture = do 608
609 tex <- gameIO . alloca $ \ptr -> do 609instance Ord Texture where
610 glGenTextures 1 ptr 610 t1 < t2 = getTex t1 < getTex t2
611 peek ptr 611
612 612instance 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. 616newTexture :: Game s Texture
617deleteTexture :: GLuint -> IO () 617newTexture = do
618--deleteTexture tex = with tex $ glDeleteTextures 1 618 tex <- gameIO . alloca $ \ptr -> do
619deleteTexture 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
624loadTextureImage :: FilePath 624
625 -> GLenum -- ^ Texture's min filter. 625-- | Delete the texture.
626 -> GLenum -- ^ Texture's mag filter. 626deleteTexture :: GLuint -> IO ()
627 -> Game s Texture 627--deleteTexture tex = with tex $ glDeleteTextures 1
628loadTextureImage file minFilter magFilter = do 628deleteTexture 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 633loadTextureImage :: 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 637loadTextureImage 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
645bindTexture :: Texture -> IO () 645
646bindTexture = 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
649unbindTexture :: IO () 649 texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter
650unbindTexture = 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'. 654bindTexture :: Texture -> IO ()
655loadTextureData :: GLenum 655bindTexture = glBindTexture gl_TEXTURE_2D . getTex
656 -> Int -- ^ Target 656
657 -> Int -- ^ Level 657-- | Unbind the bound texture.
658 -> Int -- ^ Internal format 658unbindTexture :: IO ()
659 -> Int -- ^ Width 659unbindTexture = 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 () 664loadTextureData :: GLenum
665loadTextureData 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 674loadTextureData 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)
677texParami :: GLenum -> GLenum -> SettableStateVar GLenum 677 (fromIntegral internalFormat)
678texParami 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)
681texParamf :: GLenum -> GLenum -> SettableStateVar Float 681 (fromIntegral format)
682texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) 682 texType
683 683 texData
684-- | Set the active texture unit. 684
685activeTexture :: SettableStateVar GLenum 685-- | Set the bound texture's parameter to the given value.
686activeTexture = makeSettableStateVar glActiveTexture 686texParami :: GLenum -> GLenum -> SettableStateVar GLenum
687 687texParami 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-- 690texParamf :: GLenum -> GLenum -> SettableStateVar Float
691 691texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val)
692-- | Get the last OpenGL error. 692
693getGLError :: IO (Maybe String) 693-- | Set the active texture unit.
694getGLError = fmap translate glGetError 694activeTexture :: SettableStateVar GLenum
695 where 695activeTexture = 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" 702getGLError :: IO (Maybe String)
703 703getGLError = fmap translate glGetError
704-- | Print the last OpenGL error. 704 where
705printGLError :: IO () 705 translate err
706printGLError = 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.
714assertGL :: Game s a -> String -> Game s a 714printGLError :: IO ()
715assertGL action err = do 715printGLError = 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.
723assertGL :: Game s a -> String -> Game s a
724assertGL 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 @@
1module Spear.Game 1module 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
24where 24)
25 25where
26import Control.Monad.Trans.Class (lift) 26
27import Control.Monad.State.Strict 27import Control.Monad.Trans.Class (lift)
28import Control.Monad.Error 28import Control.Monad.State.Strict
29import qualified Control.Monad.Trans.Resource as R 29import Control.Monad.Error
30 30import qualified Control.Monad.Trans.Resource as R
31type Resource = R.ReleaseKey 31
32type Game s = StateT s (R.ResourceT (ErrorT String IO)) 32type Resource = R.ReleaseKey
33 33type Game s = StateT s (R.ResourceT (ErrorT String IO))
34class ResourceClass a where 34
35 getResource :: a -> Resource 35class 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
44getGameState :: Game s s 44-- | Retrieve the game state.
45getGameState = get 45getGameState :: Game s s
46 46getGameState = get
47-- | Save the game state. 47
48saveGameState :: s -> Game s () 48-- | Save the game state.
49saveGameState = put 49saveGameState :: s -> Game s ()
50 50saveGameState = put
51-- | Modify the game state. 51
52modifyGameState :: (s -> s) -> Game s () 52-- | Modify the game state.
53modifyGameState = modify 53modifyGameState :: (s -> s) -> Game s ()
54 54modifyGameState = modify
55-- | Register the given cleaner. 55
56register :: IO () -> Game s Resource 56-- | Register the given cleaner.
57register = lift . R.register 57register :: IO () -> Game s Resource
58 58register = lift . R.register
59-- | Release the given 'Resource'. 59
60unregister :: Resource -> Game s () 60-- | Release the given 'Resource'.
61unregister = lift . R.release 61unregister :: Resource -> Game s ()
62 62unregister = lift . R.release
63-- | Throw an error from the 'Game' monad. 63
64gameError :: String -> Game s a 64-- | Throw an error from the 'Game' monad.
65gameError = lift . lift . throwError 65gameError :: String -> Game s a
66 66gameError = lift . lift . throwError
67-- | Throw the given error string if given 'Nothing'. 67
68assertMaybe :: Maybe a -> String -> Game s a 68-- | Throw the given error string if given 'Nothing'.
69assertMaybe Nothing err = gameError err 69assertMaybe :: Maybe a -> String -> Game s a
70assertMaybe (Just x) _ = return x 70assertMaybe Nothing err = gameError err
71 71assertMaybe (Just x) _ = return x
72-- | Run the given game. 72
73runGame :: Game s a -> s -> IO (Either String (a,s)) 73-- | Run the given game with the given error handler.
74runGame game state = runErrorT . R.runResourceT . runStateT game $ state 74catchGameError :: Game s a -> (String -> Game s a) -> Game s a
75 75catchGameError game catch = catchError game catch
76-- | Run the given game. 76
77runGame' :: Game s a -> s -> IO () 77-- | Run the given game, catch any error, run the given finaliser and rethrow the error.
78runGame' game state = runGame game state >> return () 78catchGameErrorFinally :: Game s a -> Game s a -> Game s a
79 79catchGameErrorFinally game finally = catchError game $ \err -> finally >> gameError err
80-- | Run the given game. 80
81runSubGame :: Game s a -> s -> Game t (a,s) 81-- | Run the given game.
82runSubGame game state = lift $ runStateT game state 82runGame :: Game s a -> s -> IO (Either String (a,s))
83 83runGame game state = runErrorT . R.runResourceT . runStateT game $ state
84-- | Run the given game. 84
85runSubGame' :: Game s a -> s -> Game t () 85-- | Fully run the given sub game, unrolling the entire monad stack.
86runSubGame' game state = runSubGame game state >> return () 86runSubGame :: Game s a -> s -> Game t (a,s)
87 87runSubGame game state = gameIO (runGame game state) >>= \result -> case result of
88-- | Run the given game and return its result. 88 Left err -> gameError err
89evalSubGame :: Game s a -> s -> Game t a 89 Right x -> return x
90evalSubGame 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. 92evalSubGame :: Game s a -> s -> Game t a
93execSubGame :: Game s a -> s -> Game t s 93evalSubGame g s = runSubGame g s >>= \(a,_) -> return a
94execSubGame 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. 96execSubGame :: Game s a -> s -> Game t s
97gameIO :: IO a -> Game s a 97execSubGame g s = runSubGame g s >>= \(_,s) -> return s
98gameIO = lift . lift . lift 98
99-- | Perform the given IO action in the 'Game' monad.
100gameIO :: IO a -> Game s a
101gameIO = 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 @@
1module Spear.Math.AABB 1module 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)
10where 10where
11 11
12import Spear.Math.Vector 12import Spear.Math.Vector
13 13
14import Data.List (foldl') 14import Data.List (foldl')
15 15
16-- | An axis-aligned bounding box in 2D space. 16-- | An axis-aligned bounding box in 2D space.
17data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 17data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2
18 18
19-- | An axis-aligned bounding box in 3D space. 19-- | An axis-aligned bounding box in 3D space.
20data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 20data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3
21 21
22-- | Create a AABB from the given points. 22-- | Create a AABB from the given points.
23aabb2 :: [Vector2] -> AABB2 23aabb2 :: [Vector2] -> AABB2
24aabb2 [] = AABB2 zero2 zero2 24aabb2 [] = AABB2 zero2 zero2
25aabb2 (x:xs) = foldl' update (AABB2 x x) xs 25aabb2 (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.
29aabb3 :: [Vector3] -> AABB3 29aabb3 :: [Vector3] -> AABB3
30aabb3 [] = AABB3 zero3 zero3 30aabb3 [] = AABB3 zero3 zero3
31aabb3 (x:xs) = foldl' update (AABB3 x x) xs 31aabb3 (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.
35aabb2pt :: AABB2 -> Vector2 -> Bool 35aabb2pt :: AABB2 -> Vector2 -> Bool
36aabb2pt (AABB2 pmin pmax) v = v >= pmin && v <= pmax 36aabb2pt (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.
39aabb3pt :: AABB3 -> Vector3 -> Bool 39aabb3pt :: AABB3 -> Vector3 -> Bool
40aabb3pt (AABB3 pmin pmax) v = v >= pmin && v <= pmax 40aabb3pt (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 @@
1module Spear.Math.Camera 1module 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)
16where 16where
17 17
18import qualified Spear.Math.Matrix4 as M 18import qualified Spear.Math.Matrix4 as M
19import Spear.Math.Spatial3 19import Spear.Math.Spatial3
20import Spear.Math.Vector 20import Spear.Math.Vector
21 21
22data Camera = Camera 22data 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
27instance Spatial3 Camera where 27instance 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
31type Fovy = Float 31type Fovy = Float
32type Aspect = Float 32type Aspect = Float
33type Near = Float 33type Near = Float
34type Far = Float 34type Far = Float
35type Left = Float 35type Left = Float
36type Right = Float 36type Right = Float
37type Bottom = Float 37type Bottom = Float
38type Top = Float 38type Top = Float
39 39
40-- | Build a perspective camera. 40-- | Build a perspective camera.
41perspective :: Fovy -- ^ Fovy - Vertical field of view angle in degrees. 41perspective :: 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
51perspective fovy r n f right up fwd pos = 51perspective 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.
59ortho :: Left -- ^ Left. 59ortho :: 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
71ortho l r b t n f right up fwd pos = 71ortho 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 @@
1module Spear.Math.Circle 1module Spear.Math.Circle
2where 2where
3 3
4import Spear.Math.Vector 4import Spear.Math.Vector
5 5
6import Data.List (foldl') 6import Data.List (foldl')
7 7
8-- | A circle in 2D space. 8-- | A circle in 2D space.
9data Circle = Circle 9data 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.
15circle :: [Vector2] -> Circle 15circle :: [Vector2] -> Circle
16circle [] = Circle zero2 0 16circle [] = Circle zero2 0
17circle (x:xs) = Circle c r 17circle (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.
25circlept :: Circle -> Vector2 -> Bool 25circlept :: Circle -> Vector2 -> Bool
26circlept (Circle c r) p = r*r >= normSq (p - c) 26circlept (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 @@
1module Spear.Math.Collision 1module 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)
24where 24where
25 25
26import Spear.Assets.Model 26import Spear.Assets.Model
27import Spear.Math.AABB 27import Spear.Math.AABB
28import Spear.Math.Circle 28import Spear.Math.Circle
29import qualified Spear.Math.Matrix4 as M4 29import qualified Spear.Math.Matrix4 as M4
30import Spear.Math.Plane 30import Spear.Math.Plane
31import Spear.Math.Sphere 31import Spear.Math.Sphere
32import Spear.Math.Vector 32import Spear.Math.Vector
33 33
34import Data.List (foldl') 34import Data.List (foldl')
35 35
36data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy 36data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy
37 deriving (Eq, Show) 37 deriving (Eq, Show)
38 38
39-- 2D collision 39-- 2D collision
40 40
41class Collisionable2 a where 41class 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
49instance Collisionable2 AABB2 where 49instance 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
69instance Collisionable2 Circle where 69instance 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
85instance Collisionable2 Collisioner2 where 85instance 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
93aabbPoints :: AABB2 -> [Vector2] 93aabbPoints :: AABB2 -> [Vector2]
94aabbPoints (AABB2 min max) = [p1,p2,p3,p4,p5,p6,p7,p8] 94aabbPoints (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.
107data Collisioner2 107data 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.
115aabb2Collisioner :: AABB2 -> Collisioner2 115aabb2Collisioner :: AABB2 -> Collisioner2
116aabb2Collisioner = AABB2Col 116aabb2Collisioner = AABB2Col
117 117
118-- | Create a collisioner from the specified circle. 118-- | Create a collisioner from the specified circle.
119circleCollisioner :: Circle -> Collisioner2 119circleCollisioner :: Circle -> Collisioner2
120circleCollisioner = CircleCol 120circleCollisioner = 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.
123mkCols :: M4.Matrix4 -- ^ Modelview matrix 123mkCols :: M4.Matrix4 -- ^ Modelview matrix
124 -> Box 124 -> Box
125 -> [Collisioner2] 125 -> [Collisioner2]
126mkCols modelview (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = 126mkCols 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.
138buildAABB2 :: [Collisioner2] -> AABB2 138buildAABB2 :: [Collisioner2] -> AABB2
139buildAABB2 cols = aabb2 $ generatePoints cols 139buildAABB2 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.
142aabb2FromCircle :: Circle -> AABB2 142aabb2FromCircle :: Circle -> AABB2
143aabb2FromCircle (Circle c r) = AABB2 bot top 143aabb2FromCircle (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.
149circleFromAABB2 :: AABB2 -> Circle 149circleFromAABB2 :: AABB2 -> Circle
150circleFromAABB2 (AABB2 min max) = Circle c r 150circleFromAABB2 (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
155generatePoints :: [Collisioner2] -> [Vector2] 155generatePoints :: [Collisioner2] -> [Vector2]
156generatePoints = foldl' generate [] 156generatePoints = 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.
177collide :: Collisioner2 -> Collisioner2 -> CollisionType 177collide :: Collisioner2 -> Collisioner2 -> CollisionType
178collide (AABB2Col box1) (AABB2Col box2) = collideAABB2 box1 box2 178collide (AABB2Col box1) (AABB2Col box2) = collideAABB2 box1 box2
179collide (AABB2Col box) (CircleCol circle) = collideAABB2 box circle 179collide (AABB2Col box) (CircleCol circle) = collideAABB2 box circle
180collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2 180collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2
181collide (CircleCol circle) (AABB2Col box) = collideCircle circle box 181collide (CircleCol circle) (AABB2Col box) = collideCircle circle box
182 182
183-- | Move the collisioner. 183-- | Move the collisioner.
184move :: Vector2 -> Collisioner2 -> Collisioner2 184move :: Vector2 -> Collisioner2 -> Collisioner2
185move v (AABB2Col (AABB2 min max)) = AABB2Col (AABB2 (min+v) (max+v)) 185move v (AABB2Col (AABB2 min max)) = AABB2Col (AABB2 (min+v) (max+v))
186move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r) 186move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r)
187 187
188 188
189-- 3D collision 189-- 3D collision
190 190
191class Collisionable3 a where 191class 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
199instance Collisionable3 AABB3 where 199instance 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
220instance Collisionable3 Sphere where 220instance 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.
238aabb3FromSphere :: Sphere -> AABB3 238aabb3FromSphere :: Sphere -> AABB3
239aabb3FromSphere (Sphere c r) = AABB3 bot top 239aabb3FromSphere (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 @@
1module Spear.Math.Entity 1module Spear.Math.Entity
2( 2(
3 Entity(..) 3 Entity(..)
4) 4)
5where 5where
6 6
7 7
8import qualified Spear.Math.Matrix3 as M 8import qualified Spear.Math.Matrix3 as M
9import qualified Spear.Math.Spatial2 as S 9import qualified Spear.Math.Spatial2 as S
10import qualified Spear.Math.Vector as V 10import qualified Spear.Math.Vector as V
11 11
12 12
13-- | An entity in 2D space. 13-- | An entity in 2D space.
14newtype Entity = Entity { transform :: M.Matrix3 } 14newtype Entity = Entity { transform :: M.Matrix3 }
15 15
16 16
17instance S.Spatial2 Entity where 17instance 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 @@
1module Spear.Math.Frustum 1module Spear.Math.Frustum
2where 2where
3 3
4import Spear.Math.Plane 4import Spear.Math.Plane
5 5
6data Frustum = Frustum 6data 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.
16frustum 16frustum
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
24frustum = Frustum 24frustum = Frustum
25 25
26-- | Construct a frustum. 26-- | Construct a frustum.
27fromList :: [Plane] -> Frustum 27fromList :: [Plane] -> Frustum
28fromList (n:f:l:r:t:b:_) = Frustum n f l r t b 28fromList (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 @@
1module Spear.Math.Matrix3 1module 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)
40where 40where
41 41
42 42
43import Spear.Math.Vector 43import Spear.Math.Vector
44 44
45import Foreign.Storable 45import Foreign.Storable
46 46
47 47
48-- | Represents a 3x3 column major matrix. 48-- | Represents a 3x3 column major matrix.
49data Matrix3 = Matrix3 49data 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
56instance Show Matrix3 where 56instance 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
66instance Num Matrix3 where 66instance 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
100instance Storable Matrix3 where 100instance 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
121col0 (Matrix3 a00 _ _ a01 _ _ a02 _ _ ) = vec3 a00 a01 a02 121col0 (Matrix3 a00 _ _ a01 _ _ a02 _ _ ) = vec3 a00 a01 a02
122col1 (Matrix3 _ a10 _ _ a11 _ _ a12 _ ) = vec3 a10 a11 a12 122col1 (Matrix3 _ a10 _ _ a11 _ _ a12 _ ) = vec3 a10 a11 a12
123col2 (Matrix3 _ _ a20 _ _ a21 _ _ a22) = vec3 a20 a21 a22 123col2 (Matrix3 _ _ a20 _ _ a21 _ _ a22) = vec3 a20 a21 a22
124 124
125 125
126row0 (Matrix3 a00 a10 a20 _ _ _ _ _ _ ) = vec3 a00 a10 a20 126row0 (Matrix3 a00 a10 a20 _ _ _ _ _ _ ) = vec3 a00 a10 a20
127row1 (Matrix3 _ _ _ a01 a11 a21 _ _ _ ) = vec3 a01 a11 a21 127row1 (Matrix3 _ _ _ a01 a11 a21 _ _ _ ) = vec3 a01 a11 a21
128row2 (Matrix3 _ _ _ _ _ _ a02 a12 a22) = vec3 a02 a12 a22 128row2 (Matrix3 _ _ _ _ _ _ a02 a12 a22) = vec3 a02 a12 a22
129 129
130 130
131right (Matrix3 a00 _ _ a01 _ _ _ _ _) = vec2 a00 a01 131right (Matrix3 a00 _ _ a01 _ _ _ _ _) = vec2 a00 a01
132up (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 132up (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11
133forward (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 133forward (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11
134position (Matrix3 _ _ a20 _ _ a21 _ _ _) = vec2 a20 a21 134position (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.
138mat3 = Matrix3 138mat3 = Matrix3
139 139
140 140
141-- | Build a matrix from three vectors in 3D. 141-- | Build a matrix from three vectors in 3D.
142mat3fromVec :: Vector3 -> Vector3 -> Vector3 -> Matrix3 142mat3fromVec :: Vector3 -> Vector3 -> Vector3 -> Matrix3
143mat3fromVec v0 v1 v2 = Matrix3 143mat3fromVec 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.
150transform :: Vector2 -- ^ Right vector 150transform :: 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
155transform r f p = mat3 155transform 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.
162translation :: Matrix3 -> Matrix3 162translation :: Matrix3 -> Matrix3
163translation (Matrix3 163translation (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.
174rotation :: Matrix3 -> Matrix3 174rotation :: Matrix3 -> Matrix3
175rotation (Matrix3 175rotation (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.
186id :: Matrix3 186id :: Matrix3
187id = mat3 187id = 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.
194transl :: Float -- ^ Translation on the x axis 194transl :: 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
198transl tx ty = mat3 198transl 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.
205translv :: Vector2 -> Matrix3 205translv :: Vector2 -> Matrix3
206translv v = mat3 206translv 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.
215rot :: Float -> Matrix3 215rot :: Float -> Matrix3
216rot angle = mat3 216rot 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.
226scale :: Float -> Float -> Float -> Matrix3 226scale :: Float -> Float -> Float -> Matrix3
227scale sx sy sz = mat3 227scale 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.
234scalev :: Vector3 -> Matrix3 234scalev :: Vector3 -> Matrix3
235scalev v = mat3 235scalev 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.
246reflectX :: Matrix3 246reflectX :: Matrix3
247reflectX = mat3 247reflectX = 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.
254reflectY :: Matrix3 254reflectY :: Matrix3
255reflectY = mat3 255reflectY = 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.
262reflectZ :: Matrix3 262reflectZ :: Matrix3
263reflectZ = mat3 263reflectZ = 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.
270transpose :: Matrix3 -> Matrix3 270transpose :: Matrix3 -> Matrix3
271transpose m = mat3 271transpose 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.
278mulp :: Matrix3 -> Vector2 -> Vector2 278mulp :: Matrix3 -> Vector2 -> Vector2
279mulp m v = vec2 x' y' 279mulp 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.
288muld :: Matrix3 -> Vector2 -> Vector2 288muld :: Matrix3 -> Vector2 -> Vector2
289muld m v = vec2 x' y' 289muld 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.
297mul :: Matrix3 -> Vector3 -> Vector3 297mul :: Matrix3 -> Vector3 -> Vector3
298mul m v = vec3 x' y' z' 298mul 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.
307zipWith :: (Float -> Float -> Float) -> Matrix3 -> Matrix3 -> Matrix3 307zipWith :: (Float -> Float -> Float) -> Matrix3 -> Matrix3 -> Matrix3
308zipWith f a b = Matrix3 308zipWith 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'.
315map :: (Float -> Float) -> Matrix3 -> Matrix3 315map :: (Float -> Float) -> Matrix3 -> Matrix3
316map f m = Matrix3 316map 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.
323inverseTransform :: Matrix3 -> Matrix3 323inverseTransform :: Matrix3 -> Matrix3
324inverseTransform mat = 324inverseTransform 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
334fromDeg :: (Floating a) => a -> a 334fromDeg :: (Floating a) => a -> a
335fromDeg = (*pi) . (/180) 335fromDeg = (*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 @@
1module Spear.Math.Matrix4 1module 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)
51where 51where
52 52
53 53
54import Spear.Math.Vector 54import Spear.Math.Vector
55 55
56import Foreign.Storable 56import Foreign.Storable
57 57
58 58
59-- | Represents a 4x4 column major matrix. 59-- | Represents a 4x4 column major matrix.
60data Matrix4 = Matrix4 60data 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
68instance Show Matrix4 where 68instance 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
79instance Num Matrix4 where 79instance 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
123instance Storable Matrix4 where 123instance 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
148col0 (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ a03 _ _ _ ) = vec4 a00 a01 a02 a03 148col0 (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ a03 _ _ _ ) = vec4 a00 a01 a02 a03
149col1 (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ a13 _ _ ) = vec4 a10 a11 a12 a13 149col1 (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ a13 _ _ ) = vec4 a10 a11 a12 a13
150col2 (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ a23 _ ) = vec4 a20 a21 a22 a23 150col2 (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ a23 _ ) = vec4 a20 a21 a22 a23
151col3 (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ a33) = vec4 a30 a31 a32 a33 151col3 (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ a33) = vec4 a30 a31 a32 a33
152 152
153 153
154row0 (Matrix4 a00 a01 a02 a03 _ _ _ _ _ _ _ _ _ _ _ _ ) = vec4 a00 a01 a02 a03 154row0 (Matrix4 a00 a01 a02 a03 _ _ _ _ _ _ _ _ _ _ _ _ ) = vec4 a00 a01 a02 a03
155row1 (Matrix4 _ _ _ _ a10 a11 a12 a13 _ _ _ _ _ _ _ _ ) = vec4 a10 a11 a12 a13 155row1 (Matrix4 _ _ _ _ a10 a11 a12 a13 _ _ _ _ _ _ _ _ ) = vec4 a10 a11 a12 a13
156row2 (Matrix4 _ _ _ _ _ _ _ _ a20 a21 a22 a23 _ _ _ _ ) = vec4 a20 a21 a22 a23 156row2 (Matrix4 _ _ _ _ _ _ _ _ a20 a21 a22 a23 _ _ _ _ ) = vec4 a20 a21 a22 a23
157row3 (Matrix4 _ _ _ _ _ _ _ _ _ _ _ _ a30 a31 a32 a33) = vec4 a30 a31 a32 a33 157row3 (Matrix4 _ _ _ _ _ _ _ _ _ _ _ _ a30 a31 a32 a33) = vec4 a30 a31 a32 a33
158 158
159 159
160right (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ _ _ _ _) = vec3 a00 a01 a02 160right (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ _ _ _ _) = vec3 a00 a01 a02
161up (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ _ _ _) = vec3 a10 a11 a12 161up (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ _ _ _) = vec3 a10 a11 a12
162forward (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ _ _) = vec3 a20 a21 a22 162forward (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ _ _) = vec3 a20 a21 a22
163position (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ _) = vec3 a30 a31 a32 163position (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.
167mat4 = Matrix4 167mat4 = Matrix4
168 168
169 169
170-- | Build a matrix from four vectors in 4D. 170-- | Build a matrix from four vectors in 4D.
171mat4fromVec :: Vector4 -> Vector4 -> Vector4 -> Vector4 -> Matrix4 171mat4fromVec :: Vector4 -> Vector4 -> Vector4 -> Vector4 -> Matrix4
172mat4fromVec v0 v1 v2 v3 = Matrix4 172mat4fromVec 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.
180transform :: Vector3 -- ^ Right vector. 180transform :: 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
186transform right up fwd pos = mat4 186transform 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.
194translation :: Matrix4 -> Matrix4 194translation :: Matrix4 -> Matrix4
195translation (Matrix4 195translation (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.
208rotation :: Matrix4 -> Matrix4 208rotation :: Matrix4 -> Matrix4
209rotation (Matrix4 209rotation (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.
222lookAt :: Vector3 -- ^ Eye position. 222lookAt :: Vector3 -- ^ Eye position.
223 -> Vector3 -- ^ Target point. 223 -> Vector3 -- ^ Target point.
224 -> Matrix4 224 -> Matrix4
225 225
226lookAt pos target = 226lookAt 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.
235zipWith :: (Float -> Float -> Float) -> Matrix4 -> Matrix4 -> Matrix4 235zipWith :: (Float -> Float -> Float) -> Matrix4 -> Matrix4 -> Matrix4
236zipWith f a b = Matrix4 236zipWith 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.
244map :: (Float -> Float) -> Matrix4 -> Matrix4 244map :: (Float -> Float) -> Matrix4 -> Matrix4
245map f m = Matrix4 245map 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.
253id :: Matrix4 253id :: Matrix4
254id = mat4 254id = 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.
262transl :: Float -> Float -> Float -> Matrix4 262transl :: Float -> Float -> Float -> Matrix4
263transl x y z = mat4 263transl 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.
271translv :: Vector3 -> Matrix4 271translv :: Vector3 -> Matrix4
272translv v = mat4 272translv 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.
281rotX :: Float -> Matrix4 281rotX :: Float -> Matrix4
282rotX angle = mat4 282rotX 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.
294rotY :: Float -> Matrix4 294rotY :: Float -> Matrix4
295rotY angle = mat4 295rotY 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.
307rotZ :: Float -> Matrix4 307rotZ :: Float -> Matrix4
308rotZ angle = mat4 308rotZ 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.
320axisAngle :: Vector3 -> Float -> Matrix4 320axisAngle :: Vector3 -> Float -> Matrix4
321axisAngle v angle = mat4 321axisAngle 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.
342scale :: Float -> Float -> Float -> Matrix4 342scale :: Float -> Float -> Float -> Matrix4
343scale sx sy sz = mat4 343scale 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.
351scalev :: Vector3 -> Matrix4 351scalev :: Vector3 -> Matrix4
352scalev v = mat4 352scalev 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.
364reflectX :: Matrix4 364reflectX :: Matrix4
365reflectX = mat4 365reflectX = 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.
373reflectY :: Matrix4 373reflectY :: Matrix4
374reflectY = mat4 374reflectY = 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.
382reflectZ :: Matrix4 382reflectZ :: Matrix4
383reflectZ = mat4 383reflectZ = 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.
391ortho :: Float -- ^ Left. 391ortho :: 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
399ortho l r b t n f = 399ortho 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.
411perspective :: Float -- ^ Fovy - Vertical field of view angle in degrees. 411perspective :: 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
416perspective fovy r near far = 416perspective 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.
427planeProj :: Vector3 -- ^ Plane normal 427planeProj :: 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
431planeProj n d l = 431planeProj 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.
447transpose :: Matrix4 -> Matrix4 447transpose :: Matrix4 -> Matrix4
448transpose m = mat4 448transpose 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.
456inverseTransform :: Matrix4 -> Matrix4 456inverseTransform :: Matrix4 -> Matrix4
457inverseTransform mat = 457inverseTransform 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.
472inverse :: Matrix4 -> Matrix4 472inverse :: Matrix4 -> Matrix4
473inverse mat = 473inverse 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.
617mul :: Float -> Matrix4 -> Vector3 -> Vector3 617mul :: Float -> Matrix4 -> Vector3 -> Vector3
618mul w m v = vec3 x' y' z' 618mul 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.
627mulp :: Matrix4 -> Vector3 -> Vector3 627mulp :: Matrix4 -> Vector3 -> Vector3
628mulp = mul 1 628mulp = 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.
632muld :: Matrix4 -> Vector3 -> Vector3 632muld :: Matrix4 -> Vector3 -> Vector3
633muld = mul 0 633muld = 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.
640mul' :: Float -> Matrix4 -> Vector3 -> Vector3 640mul' :: Float -> Matrix4 -> Vector3 -> Vector3
641mul' w m v = vec3 (x'/w') (y'/w') (z'/w') 641mul' 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
650toRAD = (*pi) . (/180) 650toRAD = (*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 @@
1module Spear.Math.MatrixUtils 1module 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)
12where 12where
13 13
14 14
15import Spear.Math.Camera as Cam 15import Spear.Math.Camera as Cam
16import Spear.Math.Matrix3 as M3 16import Spear.Math.Matrix3 as M3
17import Spear.Math.Matrix4 as M4 17import Spear.Math.Matrix4 as M4
18import Spear.Math.Spatial3 as S 18import Spear.Math.Spatial3 as S
19import Spear.Math.Vector as V 19import 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.
23fastNormalMatrix :: Matrix4 -> Matrix3 23fastNormalMatrix :: Matrix4 -> Matrix3
24fastNormalMatrix m = 24fastNormalMatrix 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.
33unproject :: Matrix4 -- ^ Inverse projection matrix 33unproject :: 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
43unproject projI modelviewI vpx vpy w h x y z = 43unproject 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.
56rpgUnproject 56rpgUnproject
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
66rpgUnproject projI viewI vpx vpy w h wx wy = 66rpgUnproject 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.
77rpgTransform 77rpgTransform
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
84rpgTransform h a axis pos viewI = 84rpgTransform 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.
102pltTransform :: Matrix3 -> Matrix4 102pltTransform :: Matrix3 -> Matrix4
103pltTransform mat = 103pltTransform 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.
120rpgInverse 120rpgInverse
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
127rpgInverse h a axis pos viewI = 127rpgInverse 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.
138pltInverse :: Matrix3 -> Matrix4 138pltInverse :: Matrix3 -> Matrix4
139pltInverse = M4.inverseTransform . pltTransform 139pltInverse = 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.
143objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 143objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2
144objToClip cam model p = 144objToClip 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 @@
1module Spear.Math.Octree 1module 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)
10where 10where
11 11
12import Spear.Math.AABB 12import Spear.Math.AABB
13import Spear.Math.Collision 13import Spear.Math.Collision
14import Spear.Math.Vector 14import Spear.Math.Vector
15 15
16import Control.Applicative ((<*>)) 16import Control.Applicative ((<*>))
17import Data.List 17import Data.List
18import Data.Functor 18import Data.Functor
19import Data.Monoid 19import Data.Monoid
20import qualified Data.Foldable as F 20import qualified Data.Foldable as F
21 21
22-- | An octree. 22-- | An octree.
23data Octree e 23data 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.
43makeOctree :: Int -> AABB2 -> Octree e 43makeOctree :: Int -> AABB2 -> Octree e
44makeOctree d root@(AABB2 min max) 44makeOctree 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
58subdivide :: AABB2 -> [AABB2] 58subdivide :: AABB2 -> [AABB2]
59subdivide (AABB2 min max) = [a1, a2, a3, a4, a5, a6, a7, a8] 59subdivide (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.
73clone :: Octree e -> Octree e 73clone :: Octree e -> Octree e
74clone (Leaf root ents) = Leaf root [] 74clone (Leaf root ents) = Leaf root []
75clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8' 75clone (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
86keep :: (e -> AABB2 -> CollisionType) -> AABB2 -> e -> Bool 86keep :: (e -> AABB2 -> CollisionType) -> AABB2 -> e -> Bool
87keep testAABB2 aabb e = test == FullyContainedBy 87keep 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.
91insert :: (e -> AABB2 -> CollisionType) -> Octree e -> [e] -> Octree e 91insert :: (e -> AABB2 -> CollisionType) -> Octree e -> [e] -> Octree e
92insert testAABB2 octree es = octree' where (octree', _) = insert' testAABB2 es octree 92insert testAABB2 octree es = octree' where (octree', _) = insert' testAABB2 es octree
93 93
94insert' :: (e -> AABB2 -> CollisionType) -> [e] -> Octree e -> (Octree e, [e]) 94insert' :: (e -> AABB2 -> CollisionType) -> [e] -> Octree e -> (Octree e, [e])
95 95
96insert' testAABB2 es (Leaf root ents) = (Leaf root ents', outliers) 96insert' 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
102insert' testAABB2 es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = 102insert' 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.
119extract :: Octree e -> (Octree e, [e]) 119extract :: Octree e -> (Octree e, [e])
120extract (Leaf root ents) = (Leaf root [], ents) 120extract (Leaf root ents) = (Leaf root [], ents)
121extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents') 121extract (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.
136map :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> Octree e 136map :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> Octree e
137map testAABB2 f o = 137map 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
141map' :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e]) 141map' :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e])
142 142
143map' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) 143map' 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
149map' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = 149map' 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.
168gmap :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e 168gmap :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e
169gmap testAABB2 f o = 169gmap 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
173gmap' :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e]) 173gmap' :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e])
174 174
175gmap' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) 175gmap' 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
181gmap' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = 181gmap' 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
196instance Functor Octree where 196instance 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
212instance F.Foldable Octree where 212instance 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 @@
1module Spear.Math.Physics 1module 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)
6where 6where
7 7
8import Spear.Math.Physics.Rigid 8import Spear.Math.Physics.Rigid
9import Spear.Math.Physics.Types 9import 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 @@
1module Spear.Math.Physics.Rigid 1module 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)
10where 10where
11 11
12import qualified Spear.Math.Matrix3 as M3 12import qualified Spear.Math.Matrix3 as M3
13import Spear.Math.Spatial2 13import Spear.Math.Spatial2
14import Spear.Math.Vector 14import Spear.Math.Vector
15import Spear.Physics.Types 15import Spear.Physics.Types
16 16
17import Data.List (foldl') 17import Data.List (foldl')
18import Control.Monad.State 18import Control.Monad.State
19 19
20data RigidBody = RigidBody 20data 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
27instance Spatial2 RigidBody where 27instance 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'.
58rigidBody :: Mass -> Position -> RigidBody 58rigidBody :: Mass -> Position -> RigidBody
59rigidBody m x = RigidBody m x zero2 zero2 59rigidBody m x = RigidBody m x zero2 zero2
60 60
61-- | Update the given 'RigidBody'. 61-- | Update the given 'RigidBody'.
62update :: [Force] -> Dt -> RigidBody -> RigidBody 62update :: [Force] -> Dt -> RigidBody -> RigidBody
63update forces dt body = 63update 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.
77setVelocity :: Velocity -> RigidBody -> RigidBody 77setVelocity :: Velocity -> RigidBody -> RigidBody
78setVelocity v body = body { velocity = v } 78setVelocity v body = body { velocity = v }
79 79
80-- | Set the body's acceleration. 80-- | Set the body's acceleration.
81setAcceleration :: Acceleration -> RigidBody -> RigidBody 81setAcceleration :: Acceleration -> RigidBody -> RigidBody
82setAcceleration a body = body { acceleration = a } 82setAcceleration a body = body { acceleration = a }
83 83
84 84
85-- test 85-- test
86{-gravity = vec2 0 (-10) 86{-gravity = vec2 0 (-10)
87b0 = rigidBody 50 $ vec2 0 1000 87b0 = rigidBody 50 $ vec2 0 1000
88 88
89 89
90debug :: IO () 90debug :: IO ()
91debug = evalStateT debug' b0 91debug = evalStateT debug' b0
92 92
93 93
94 94
95debug' :: StateT RigidBody IO () 95debug' :: StateT RigidBody IO ()
96debug' = do 96debug' = 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
111step :: (RigidBody -> RigidBody) -> StateT RigidBody IO () 111step :: (RigidBody -> RigidBody) -> StateT RigidBody IO ()
112step update = do 112step 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
118show' body = 118show' 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
125showVec v = (show $ x v) ++ ", " ++ (show $ y v)-} 125showVec 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 @@
1module Spear.Math.Physics.Types 1module Spear.Math.Physics.Types
2where 2where
3 3
4import Spear.Math.Vector 4import Spear.Math.Vector
5 5
6type Dt = Float 6type Dt = Float
7type Force = Vector2 7type Force = Vector2
8type Mass = Float 8type Mass = Float
9type Position = Vector2 9type Position = Vector2
10type Velocity = Vector2 10type Velocity = Vector2
11type Acceleration = Vector2 11type 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 @@
1module Spear.Math.Plane 1module Spear.Math.Plane
2( 2(
3 Plane 3 Plane
4, plane 4, plane
5, classify 5, classify
6) 6)
7where 7where
8 8
9import Spear.Math.Vector 9import Spear.Math.Vector
10 10
11data PointPlanePos = Front | Back | Contained deriving (Eq, Show) 11data PointPlanePos = Front | Back | Contained deriving (Eq, Show)
12 12
13data Plane = Plane 13data 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.
20plane :: Vector3 -> Float -> Plane 20plane :: Vector3 -> Float -> Plane
21plane n d = Plane (normalise n) d 21plane 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.
26fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane 26fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane
27fromPoints p0 p1 p2 = Plane n d 27fromPoints 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.
34classify :: Plane -> Vector3 -> PointPlanePos 34classify :: Plane -> Vector3 -> PointPlanePos
35classify (Plane n d) pt = 35classify (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 @@
1module Spear.Math.Quaternion 1module 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)
17where 17where
18 18
19 19
20import Spear.Math.Vector 20import Spear.Math.Vector
21 21
22 22
23newtype Quaternion = Quaternion { getVec :: Vector4 } 23newtype Quaternion = Quaternion { getVec :: Vector4 }
24 24
25 25
26-- | Build a 'Quaternion'. 26-- | Build a 'Quaternion'.
27quat :: Float -- x 27quat :: Float -- x
28 -> Float -- y 28 -> Float -- y
29 -> Float -- z 29 -> Float -- z
30 -> Float -- w 30 -> Float -- w
31 -> Quaternion 31 -> Quaternion
32quat x y z w = Quaternion $ vec4 x y z w 32quat 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'.
36qvec4 :: Vector4 -> Quaternion 36qvec4 :: Vector4 -> Quaternion
37qvec4 = Quaternion 37qvec4 = 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.
41qvec3 :: Vector3 -> Float -> Quaternion 41qvec3 :: Vector3 -> Float -> Quaternion
42qvec3 v w = Quaternion $ vec4 (x v) (y v) (z v) w 42qvec3 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.
46qAxisAngle :: Vector3 -> Float -> Quaternion 46qAxisAngle :: Vector3 -> Float -> Quaternion
47qAxisAngle axis angle = 47qAxisAngle 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.
61qmul :: Quaternion -> Quaternion -> Quaternion 61qmul :: Quaternion -> Quaternion -> Quaternion
62qmul (Quaternion q1) (Quaternion q2) = 62qmul (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'.
80qconj :: Quaternion -> Quaternion 80qconj :: Quaternion -> Quaternion
81qconj (Quaternion q) = Quaternion $ vec4 (-x q) (-y q) (-z q) (w q) 81qconj (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'.
85qinv :: Quaternion -> Quaternion 85qinv :: Quaternion -> Quaternion
86qinv (Quaternion q) = 86qinv (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'.
92qnormalise :: Quaternion -> Quaternion 92qnormalise :: Quaternion -> Quaternion
93qnormalise = Quaternion . normalise . getVec 93qnormalise = Quaternion . normalise . getVec
94 94
95 95
96-- | Compute the norm of the given 'Quaternion'. 96-- | Compute the norm of the given 'Quaternion'.
97qnorm :: Quaternion -> Float 97qnorm :: Quaternion -> Float
98qnorm = norm . getVec 98qnorm = norm . getVec
99 99
100 100
101-- | Rotate the given 'Vector3'. 101-- | Rotate the given 'Vector3'.
102qrot :: Quaternion -> Vector3 -> Vector3 102qrot :: Quaternion -> Vector3 -> Vector3
103qrot q v = toVec3 $ q `qmul` qvec3 v 0 `qmul` qconj q 103qrot 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
107toRAD = pi / 180 107toRAD = 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 @@
1module Spear.Math.Ray 1module Spear.Math.Ray
2( 2(
3 Ray(..) 3 Ray(..)
4, raylr 4, raylr
5, rayfb 5, rayfb
6) 6)
7where 7where
8 8
9 9
10import Spear.Math.Utils 10import Spear.Math.Utils
11import Spear.Math.Vector 11import Spear.Math.Vector
12 12
13 13
14data Ray = Ray 14data 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.
21raylr :: Ray -> Vector2 -> Side 21raylr :: Ray -> Vector2 -> Side
22raylr (Ray o d) p 22raylr (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.
28rayfb :: Ray -> Vector2 -> Face 28rayfb :: Ray -> Vector2 -> Face
29rayfb (Ray o d) p 29rayfb (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 @@
1module Spear.Math.Segment 1module Spear.Math.Segment
2( 2(
3 Segment(..) 3 Segment(..)
4, seglr 4, seglr
5) 5)
6where 6where
7 7
8 8
9import Spear.Math.Utils 9import Spear.Math.Utils
10import Spear.Math.Vector 10import Spear.Math.Vector
11 11
12 12
13-- | A line segment in 2D space. 13-- | A line segment in 2D space.
14data Segment = Segment {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 14data 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.
18seglr :: Segment -> Vector2 -> Side 18seglr :: Segment -> Vector2 -> Side
19seglr (Segment p0 p1) p 19seglr (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 @@
1module Spear.Math.Spatial2 1module Spear.Math.Spatial2
2where 2where
3 3
4 4
5import Spear.Math.Vector 5import Spear.Math.Vector
6import Spear.Math.Matrix3 as M 6import 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.
10class Spatial2 s where 10class 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 @@
1module Spear.Math.Spatial3 1module Spear.Math.Spatial3
2( 2(
3 Spatial3(..) 3 Spatial3(..)
4, Obj3 4, Obj3
5, fromVectors 5, fromVectors
6, fromTransform 6, fromTransform
7) 7)
8where 8where
9 9
10import Spear.Math.Vector 10import Spear.Math.Vector
11import qualified Spear.Math.Matrix4 as M 11import qualified Spear.Math.Matrix4 as M
12 12
13type Matrix4 = M.Matrix4 13type Matrix4 = M.Matrix4
14 14
15class Spatial3 s where 15class 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.
144data Obj3 = Obj3 144data 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
151instance Spatial3 Obj3 where 151instance Spatial3 Obj3 where
152 getObj3 = id 152 getObj3 = id
153 setObj3 _ o' = o' 153 setObj3 _ o' = o'
154 154
155fromVectors :: Right3 -> Up3 -> Forward3 -> Position3 -> Obj3 155fromVectors :: Right3 -> Up3 -> Forward3 -> Position3 -> Obj3
156fromVectors = Obj3 156fromVectors = Obj3
157 157
158fromTransform :: Matrix4 -> Obj3 158fromTransform :: Matrix4 -> Obj3
159fromTransform m = Obj3 (M.right m) (M.up m) (M.forward m) (M.position m) 159fromTransform m = Obj3 (M.right m) (M.up m) (M.forward m) (M.position m)
160 160
161toRAD = (*pi) . (/180) 161toRAD = (*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 @@
1module Spear.Math.Sphere 1module Spear.Math.Sphere
2where 2where
3 3
4import Spear.Math.Vector 4import Spear.Math.Vector
5 5
6import Data.List (foldl') 6import Data.List (foldl')
7 7
8-- | A sphere in 3D space. 8-- | A sphere in 3D space.
9data Sphere = Sphere 9data 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.
15sphere :: [Vector3] -> Sphere 15sphere :: [Vector3] -> Sphere
16sphere [] = Sphere zero3 0 16sphere [] = Sphere zero3 0
17sphere (x:xs) = Sphere c r 17sphere (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.
25circlept :: Sphere -> Vector3 -> Bool 25circlept :: Sphere -> Vector3 -> Bool
26circlept (Sphere c r) p = r*r >= normSq (p - c) 26circlept (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 @@
1module Spear.Math.Triangle 1module Spear.Math.Triangle
2( 2(
3 Triangle(..) 3 Triangle(..)
4) 4)
5where 5where
6 6
7 7
8import Spear.Math.Vector 8import Spear.Math.Vector
9 9
10import Foreign.C.Types 10import Foreign.C.Types
11import Foreign.Storable 11import Foreign.Storable
12 12
13 13
14data Triangle = Triangle 14data 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
21sizeVector3 = 3 * sizeOf (undefined :: CFloat) 21sizeVector3 = 3 * sizeOf (undefined :: CFloat)
22 22
23 23
24instance Storable Triangle where 24instance 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 @@
1module Spear.Math.Utils 1module Spear.Math.Utils
2( 2(
3 Side(..) 3 Side(..)
4, Face(..) 4, Face(..)
5, orientation2d 5, orientation2d
6, viewToWorld2d 6, viewToWorld2d
7) 7)
8where 8where
9 9
10 10
11import Spear.Math.Matrix4 as M4 11import Spear.Math.Matrix4 as M4
12import Spear.Math.Vector as V 12import Spear.Math.Vector as V
13 13
14 14
15data Side = L | R deriving (Eq, Show) 15data Side = L | R deriving (Eq, Show)
16 16
17 17
18data Face = F | B deriving (Eq, Show) 18data 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.
22orientation2d :: Vector2 -> Vector2 -> Vector2 -> Float 22orientation2d :: Vector2 -> Vector2 -> Vector2 -> Float
23orientation2d p q r = (x q - x p) * (y r - y p) - (y q - y p) * (x r - x p) 23orientation2d 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.
27viewToWorld2d :: Vector2 -- ^ Point in view space 27viewToWorld2d :: 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
30viewToWorld2d p viewI = 30viewToWorld2d 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 @@
1module Spear.Math.Vector 1module 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)
8where 8where
9 9
10import Spear.Math.Vector.Vector2 10import Spear.Math.Vector.Vector2
11import Spear.Math.Vector.Vector3 11import Spear.Math.Vector.Vector3
12import Spear.Math.Vector.Vector4 12import Spear.Math.Vector.Vector4
13import Spear.Math.Vector.Class 13import 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 @@
1module Spear.Math.Vector.Class 1module Spear.Math.Vector.Class
2where 2where
3 3
4class (Fractional a, Ord a) => VectorClass a where 4class (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 @@
1module Spear.Math.Vector.Vector2 1module 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)
12where 12where
13 13
14 14
15import Spear.Math.Vector.Class 15import Spear.Math.Vector.Class
16 16
17 17
18import Foreign.C.Types (CFloat) 18import Foreign.C.Types (CFloat)
19import Foreign.Storable 19import Foreign.Storable
20 20
21 21
22-- | Represents a vector in 2D. 22-- | Represents a vector in 2D.
23data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) 23data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show)
24 24
25 25
26instance Num Vector2 where 26instance 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
35instance Fractional Vector2 where 35instance 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
40instance Ord Vector2 where 40instance 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
49instance VectorClass Vector2 where 49instance 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
86sizeFloat = sizeOf (undefined :: CFloat) 86sizeFloat = sizeOf (undefined :: CFloat)
87 87
88 88
89instance Storable Vector2 where 89instance 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.
108unitx2 = Vector2 1 0 108unitx2 = Vector2 1 0
109 109
110 110
111-- | Unit vector along the Y axis. 111-- | Unit vector along the Y axis.
112unity2 = Vector2 0 1 112unity2 = Vector2 0 1
113 113
114 114
115-- | Zero vector. 115-- | Zero vector.
116zero2 = Vector2 0 0 116zero2 = Vector2 0 0
117 117
118 118
119-- | Create a vector from the given values. 119-- | Create a vector from the given values.
120vec2 :: Float -> Float -> Vector2 120vec2 :: Float -> Float -> Vector2
121vec2 ax ay = Vector2 ax ay 121vec2 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)
129perp :: Vector2 -> Vector2 129perp :: Vector2 -> Vector2
130perp (Vector2 x y) = Vector2 y (-x) 130perp (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 @@
1module Spear.Math.Vector.Vector3 1module Spear.Math.Vector.Vector3
2( 2(
3 Vector3 3 Vector3
4, Right3 4, Right3
5, Up3 5, Up3
6, Forward3 6, Forward3
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)
18where 18where
19 19
20 20
21import Spear.Math.Vector.Class 21import Spear.Math.Vector.Class
22 22
23import Foreign.C.Types (CFloat) 23import Foreign.C.Types (CFloat)
24import Foreign.Storable 24import Foreign.Storable
25 25
26type Right3 = Vector3 26type Right3 = Vector3
27type Up3 = Vector3 27type Up3 = Vector3
28type Forward3 = Vector3 28type Forward3 = Vector3
29type Position3 = Vector3 29type Position3 = Vector3
30 30
31 31
32-- | Represents a vector in 3D. 32-- | Represents a vector in 3D.
33data Vector3 = Vector3 33data 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
39instance Num Vector3 where 39instance 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
48instance Fractional Vector3 where 48instance 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
53instance Ord Vector3 where 53instance 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
79instance VectorClass Vector3 where 79instance 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
120sizeFloat = sizeOf (undefined :: CFloat) 120sizeFloat = sizeOf (undefined :: CFloat)
121 121
122 122
123instance Storable Vector3 where 123instance 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.
140unitx3 = Vector3 1 0 0 140unitx3 = Vector3 1 0 0
141 141
142 142
143-- | Unit vector along the Y axis. 143-- | Unit vector along the Y axis.
144unity3 = Vector3 0 1 0 144unity3 = Vector3 0 1 0
145 145
146 146
147-- | Unit vector along the Z axis. 147-- | Unit vector along the Z axis.
148unitz3 = Vector3 0 0 1 148unitz3 = Vector3 0 0 1
149 149
150 150
151-- | Zero vector. 151-- | Zero vector.
152zero3 = Vector3 0 0 0 152zero3 = 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.
156vec3 :: Float -> Float -> Float -> Vector3 156vec3 :: Float -> Float -> Float -> Vector3
157vec3 ax ay az = Vector3 ax ay az 157vec3 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.
161orbit :: Vector3 -- ^ Sphere center. 161orbit :: 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
167orbit center radius anglex angley = 167orbit 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.
182cross :: Vector3 -> Vector3 -> Vector3 182cross :: 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 @@
1module Spear.Math.Vector.Vector4 1module Spear.Math.Vector.Vector4
2( 2(
3 Vector4 3 Vector4
4 -- * Construction 4 -- * Construction
5, unitx4 5, unitx4
6, unity4 6, unity4
7, unitz4 7, unitz4
8, vec4 8, vec4
9 -- * Operations 9 -- * Operations
10, cross' 10, cross'
11) 11)
12where 12where
13 13
14 14
15import Spear.Math.Vector.Class 15import Spear.Math.Vector.Class
16 16
17import Foreign.C.Types (CFloat) 17import Foreign.C.Types (CFloat)
18import Foreign.Storable 18import Foreign.Storable
19 19
20 20
21-- | Represents a vector in 3D. 21-- | Represents a vector in 3D.
22data Vector4 = Vector4 22data 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
30instance Num Vector4 where 30instance 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
39instance Fractional Vector4 where 39instance Fractional Vector4 where
40 Vector4 ax ay az aw / Vector4 bx by bz bw = Vector4 (ax / bx) (ay / by) (az / bz) (aw / bw) 40 Vector4 ax ay az aw / Vector4 bx by bz bw = Vector4 (ax / bx) (ay / by) (az / bz) (aw / bw)
41 fromRational r = Vector4 r' r' r' r' where r' = fromRational r 41 fromRational r = Vector4 r' r' r' r' where r' = fromRational r
42 42
43 43
44instance Ord Vector4 where 44instance Ord Vector4 where
45 Vector4 ax ay az aw <= Vector4 bx by bz bw 45 Vector4 ax ay az aw <= Vector4 bx by bz bw
46 = (ax <= bx) 46 = (ax <= bx)
47 || (az == bx && ay <= by) 47 || (az == bx && ay <= by)
48 || (ax == bx && ay == by && az <= bz) 48 || (ax == bx && ay == by && az <= bz)
49 || (ax == bx && ay == by && az == bz && aw <= bw) 49 || (ax == bx && ay == by && az == bz && aw <= bw)
50 50
51 Vector4 ax ay az aw >= Vector4 bx by bz bw 51 Vector4 ax ay az aw >= Vector4 bx by bz bw
52 = (ax >= bx) 52 = (ax >= bx)
53 || (ax == bx && ay >= by) 53 || (ax == bx && ay >= by)
54 || (ax == bx && ay == by && az >= bz) 54 || (ax == bx && ay == by && az >= bz)
55 || (ax == bx && ay == by && az == bz && aw >= bw) 55 || (ax == bx && ay == by && az == bz && aw >= bw)
56 56
57 Vector4 ax ay az aw < Vector4 bx by bz bw 57 Vector4 ax ay az aw < Vector4 bx by bz bw
58 = (ax < bx) 58 = (ax < bx)
59 || (az == bx && ay < by) 59 || (az == bx && ay < by)
60 || (ax == bx && ay == by && az < bz) 60 || (ax == bx && ay == by && az < bz)
61 || (ax == bx && ay == by && az == bz && aw < bw) 61 || (ax == bx && ay == by && az == bz && aw < bw)
62 62
63 Vector4 ax ay az aw > Vector4 bx by bz bw 63 Vector4 ax ay az aw > Vector4 bx by bz bw
64 = (ax > bx) 64 = (ax > bx)
65 || (ax == bx && ay > by) 65 || (ax == bx && ay > by)
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
76instance VectorClass Vector4 where 76instance 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
121sizeFloat = sizeOf (undefined :: CFloat) 121sizeFloat = sizeOf (undefined :: CFloat)
122 122
123 123
124instance Storable Vector4 where 124instance Storable Vector4 where
125 sizeOf _ = 4*sizeFloat 125 sizeOf _ = 4*sizeFloat
126 alignment _ = alignment (undefined :: CFloat) 126 alignment _ = alignment (undefined :: CFloat)
127 127
128 peek ptr = do 128 peek ptr = do
129 ax <- peekByteOff ptr 0 129 ax <- peekByteOff ptr 0
130 ay <- peekByteOff ptr $ 1 * sizeFloat 130 ay <- peekByteOff ptr $ 1 * sizeFloat
131 az <- peekByteOff ptr $ 2 * sizeFloat 131 az <- peekByteOff ptr $ 2 * sizeFloat
132 aw <- peekByteOff ptr $ 3 * sizeFloat 132 aw <- peekByteOff ptr $ 3 * sizeFloat
133 return (Vector4 ax ay az aw) 133 return (Vector4 ax ay az aw)
134 134
135 poke ptr (Vector4 ax ay az aw) = do 135 poke ptr (Vector4 ax ay az aw) = do
136 pokeByteOff ptr 0 ax 136 pokeByteOff ptr 0 ax
137 pokeByteOff ptr (1 * sizeFloat) ay 137 pokeByteOff ptr (1 * sizeFloat) ay
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.
143unitx4 = Vector4 1 0 0 0 143unitx4 = Vector4 1 0 0 0
144 144
145 145
146-- | Unit vector along the Y axis. 146-- | Unit vector along the Y axis.
147unity4 = Vector4 0 1 0 0 147unity4 = Vector4 0 1 0 0
148 148
149 149
150-- | Unit vector along the Z axis. 150-- | Unit vector along the Z axis.
151unitz4 = Vector4 0 0 1 0 151unitz4 = Vector4 0 0 1 0
152 152
153-- | Unit vector along the W axis. 153-- | Unit vector along the W axis.
154unitw4 = Vector4 0 0 0 1 154unitw4 = 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.
158vec4 :: Float -> Float -> Float -> Float -> Vector4 158vec4 :: Float -> Float -> Float -> Float -> Vector4
159vec4 ax ay az aw = Vector4 ax ay az aw 159vec4 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.
164cross' :: Vector4 -> Vector4 -> Vector4 164cross' :: 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 @@
1module Spear.Render.AnimatedModel 1module 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)
28where 28where
29 29
30import Spear.Assets.Model 30import Spear.Assets.Model
31import Spear.Game 31import Spear.Game
32import Spear.GL 32import Spear.GL
33import Spear.Math.AABB 33import Spear.Math.AABB
34import Spear.Math.Collision 34import Spear.Math.Collision
35import Spear.Math.Matrix4 (Matrix4) 35import Spear.Math.Matrix4 (Matrix4)
36import Spear.Math.Vector 36import Spear.Math.Vector
37import Spear.Render.Material 37import Spear.Render.Material
38import Spear.Render.Model 38import Spear.Render.Model
39import Spear.Render.Program 39import Spear.Render.Program
40 40
41import Control.Applicative ((<$>), (<*>)) 41import Control.Applicative ((<$>), (<*>))
42import qualified Data.Vector as V 42import qualified Data.Vector as V
43import Unsafe.Coerce (unsafeCoerce) 43import Unsafe.Coerce (unsafeCoerce)
44 44
45type AnimationSpeed = Float 45type 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.
50data AnimatedModelResource = AnimatedModelResource 50data 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
61instance Eq AnimatedModelResource where 61instance Eq AnimatedModelResource where
62 m1 == m2 = vao m1 == vao m2 62 m1 == m2 = vao m1 == vao m2
63 63
64instance Ord AnimatedModelResource where 64instance Ord AnimatedModelResource where
65 m1 < m2 = vao m1 < vao m2 65 m1 < m2 = vao m1 < vao m2
66 66
67instance ResourceClass AnimatedModelResource where 67instance 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.
80data AnimatedModelRenderer = AnimatedModelRenderer 80data 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
90instance Eq AnimatedModelRenderer where 90instance Eq AnimatedModelRenderer where
91 m1 == m2 = modelResource m1 == modelResource m2 91 m1 == m2 = modelResource m1 == modelResource m2
92 92
93instance Ord AnimatedModelRenderer where 93instance 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.
97animatedModelResource :: AnimatedProgramChannels 97animatedModelResource :: AnimatedProgramChannels
98 -> Material 98 -> Material
99 -> Texture 99 -> Texture
100 -> Model 100 -> Model
101 -> Game s AnimatedModelResource 101 -> Game s AnimatedModelResource
102 102
103animatedModelResource 103animatedModelResource
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.
144animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer 144animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer
145animatedModelRenderer animSpeed modelResource = 145animatedModelRenderer 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.
149update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = 149update 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.
160box :: Int -> AnimatedModelResource -> Box 160box :: Int -> AnimatedModelResource -> Box
161box i model = boxes model V.! i 161box i model = boxes model V.! i
162 162
163-- | Get the renderer's current animation. 163-- | Get the renderer's current animation.
164currentAnimation :: Enum a => AnimatedModelRenderer -> a 164currentAnimation :: Enum a => AnimatedModelRenderer -> a
165currentAnimation = toEnum . currentAnim 165currentAnimation = toEnum . currentAnim
166 166
167-- | Get the renderer's model resource. 167-- | Get the renderer's model resource.
168modelRes :: AnimatedModelRenderer -> AnimatedModelResource 168modelRes :: AnimatedModelRenderer -> AnimatedModelResource
169modelRes = modelResource 169modelRes = modelResource
170 170
171-- | Get the renderer's next frame. 171-- | Get the renderer's next frame.
172nextFrame :: AnimatedModelRenderer -> Int 172nextFrame :: AnimatedModelRenderer -> Int
173nextFrame rend = 173nextFrame 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.
181setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer 181setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer
182setAnimation anim modelRend = 182setAnimation 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.
189setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer 189setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer
190setAnimationSpeed s r = r { animationSpeed = s } 190setAnimationSpeed 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.
193bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () 193bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
194bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = 194bind (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.
203render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () 203render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
204render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = 204render 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.
216mkColsFromAnimated 216mkColsFromAnimated
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]
223mkColsFromAnimated f1 f2 fp modelview modelRes = 223mkColsFromAnimated 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 @@
1module Spear.Render.Box 1module Spear.Render.Box
2( 2(
3 render 3 render
4, renderOutwards 4, renderOutwards
5, renderInwards 5, renderInwards
6, renderEdges 6, renderEdges
7) 7)
8where 8where
9 9
10 10
11import Spear.Math.Vector3 11import Spear.Math.Vector3
12import Spear.Math.Matrix 12import Spear.Math.Matrix
13import Graphics.Rendering.OpenGL.Raw 13import Graphics.Rendering.OpenGL.Raw
14import Unsafe.Coerce 14import Unsafe.Coerce
15import Control.Monad.Instances 15import Control.Monad.Instances
16 16
17type Center = Vector3 17type Center = Vector3
18type Colour = Vector4 18type Colour = Vector4
19type Length = Float 19type Length = Float
20type Normals = [Vector3] 20type Normals = [Vector3]
21type GenerateTexCoords = Bool 21type GenerateTexCoords = Bool
22 22
23 23
24applyColour :: Colour -> IO () 24applyColour :: 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)
26applyColour = do 26applyColour = 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
34applyNormal :: Vector3 -> IO () 34applyNormal :: 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)
36applyNormal = do 36applyNormal = 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.
44render :: Center -- ^ The box's center. 44render :: 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 ()
49render c l col normals = do 49render 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
110normals = [vec3 0 0 (-1), vec3 0 0 1, vec3 1 0 0, vec3 (-1) 0 0, vec3 0 1 0, vec3 0 (-1) 0] 110normals = [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.
114renderOutwards :: Center -- ^ The box's center. 114renderOutwards :: 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 ()
118renderOutwards c l col = render c l col normals 118renderOutwards 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.
122renderInwards :: Center -- ^ The box's center. 122renderInwards :: 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 ()
126renderInwards c l col = do 126renderInwards 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
132renderEdges :: Center -- ^ The box's center. 132renderEdges :: 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 ()
136renderEdges c l col = do 136renderEdges 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 @@
1module Spear.Render.Material 1module Spear.Render.Material
2( Material(..) 2( Material(..)
3) 3)
4where 4where
5 5
6 6
7import Spear.Math.Vector 7import Spear.Math.Vector
8 8
9 9
10data Material = Material 10data 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
3module Spear.Render.Model 3module Spear.Render.Model
4( 4(
5 RenderModel(..) 5 RenderModel(..)
6, renderModelFromModel 6, renderModelFromModel
7) 7)
8where 8where
9 9
10import qualified Spear.Assets.Model as Assets 10import qualified Spear.Assets.Model as Assets
11import Spear.Game 11import Spear.Game
12 12
13import Foreign.Ptr 13import Foreign.Ptr
14import Foreign.C.Types 14import Foreign.C.Types
15import Foreign.Marshal.Alloc 15import Foreign.Marshal.Alloc
16import Foreign.Marshal.Array 16import Foreign.Marshal.Array
17import Foreign.Marshal.Utils (with) 17import Foreign.Marshal.Utils (with)
18import Foreign.Storable 18import Foreign.Storable
19 19
20#include "RenderModel.h" 20#include "RenderModel.h"
21 21
22data Vec3 = Vec3 !CFloat !CFloat !CFloat 22data Vec3 = Vec3 !CFloat !CFloat !CFloat
23 23
24data TexCoord = TexCoord !CFloat !CFloat 24data TexCoord = TexCoord !CFloat !CFloat
25 25
26data RenderModel = RenderModel 26data 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
32instance Storable RenderModel where 32instance 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
47foreign import ccall "RenderModel.h render_model_from_model_asset" 47foreign 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.
51renderModelFromModel :: Assets.Model -> IO RenderModel 51renderModelFromModel :: Assets.Model -> IO RenderModel
52renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do 52renderModelFromModel 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 @@
1module Spear.Render.Program 1module 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)
12where 12where
13 13
14import Spear.GL 14import Spear.GL
15 15
16data StaticProgram = StaticProgram 16data StaticProgram = StaticProgram
17 { staticProgram :: GLSLProgram 17 { staticProgram :: GLSLProgram
18 , staticProgramChannels :: StaticProgramChannels 18 , staticProgramChannels :: StaticProgramChannels
19 , staticProgramUniforms :: StaticProgramUniforms 19 , staticProgramUniforms :: StaticProgramUniforms
20 } 20 }
21 21
22data AnimatedProgram = AnimatedProgram 22data AnimatedProgram = AnimatedProgram
23 { animatedProgram :: GLSLProgram 23 { animatedProgram :: GLSLProgram
24 , animatedProgramChannels :: AnimatedProgramChannels 24 , animatedProgramChannels :: AnimatedProgramChannels
25 , animatedProgramUniforms :: AnimatedProgramUniforms 25 , animatedProgramUniforms :: AnimatedProgramUniforms
26 } 26 }
27 27
28data StaticProgramChannels = StaticProgramChannels 28data 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
34data AnimatedProgramChannels = AnimatedProgramChannels 34data 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
42data StaticProgramUniforms = StaticProgramUniforms 42data 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
53data AnimatedProgramUniforms = AnimatedProgramUniforms 53data 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
65class Program a where 65class Program a where
66 program :: a -> GLSLProgram 66 program :: a -> GLSLProgram
67 67
68instance Program StaticProgram where 68instance Program StaticProgram where
69 program = staticProgram 69 program = staticProgram
70 70
71instance Program AnimatedProgram where 71instance Program AnimatedProgram where
72 program = animatedProgram 72 program = animatedProgram
73 73
74class ProgramUniforms a where 74class 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
84instance ProgramUniforms StaticProgramUniforms where 84instance 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
94instance ProgramUniforms AnimatedProgramUniforms where 94instance 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
7static void safe_free (void* ptr) 7static 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.
88int populate_elements_animated (Model* model_asset, RenderModel* model) 88int 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
167int populate_elements_static (Model* model_asset, RenderModel* model) 167int 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
211int render_model_from_model_asset (Model* model_asset, RenderModel* model) 211int 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
229void render_model_free (RenderModel* model) 229void 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 **/
26typedef struct 26typedef 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}
32RenderModel; 32RenderModel;
33 33
34 34
35#ifdef __cplusplus 35#ifdef __cplusplus
36extern "C" { 36extern "C" {
37#endif 37#endif
38 38
39int render_model_from_model_asset (Model* model_asset, RenderModel* render_model); 39int render_model_from_model_asset (Model* model_asset, RenderModel* render_model);
40 40
41void render_model_free (RenderModel* model); 41void 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 @@
1module Spear.Render.Sphere 1module Spear.Render.Sphere
2( 2(
3 render 3 render
4) 4)
5where 5where
6 6
7 7
8import Spear.Math.Vector as Vector 8import Spear.Math.Vector as Vector
9import Spear.Math.Matrix 9import Spear.Math.Matrix
10import Graphics.Rendering.OpenGL.Raw 10import Graphics.Rendering.OpenGL.Raw
11import Graphics.Rendering.OpenGL.GL.Colors 11import Graphics.Rendering.OpenGL.GL.Colors
12import qualified Graphics.Rendering.OpenGL.GLU as GLU 12import qualified Graphics.Rendering.OpenGL.GLU as GLU
13import Unsafe.Coerce 13import Unsafe.Coerce
14 14
15 15
16type Center = Vector R 16type Center = Vector R
17type Radius = R 17type Radius = R
18type Colour = Vector R 18type Colour = Vector R
19 19
20 20
21applyColour :: Colour -> IO () 21applyColour :: Colour -> IO ()
22applyColour col = 22applyColour 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.
34render :: Center -> Radius -> Colour -> IO () 34render :: Center -> Radius -> Colour -> IO ()
35render c radius col = do 35render 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 @@
1module Spear.Render.StaticModel 1module 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)
18where 18where
19 19
20import Spear.Assets.Model 20import Spear.Assets.Model
21import Spear.Game 21import Spear.Game
22import Spear.GL 22import Spear.GL
23import Spear.Math.AABB 23import Spear.Math.AABB
24import Spear.Math.Collision 24import Spear.Math.Collision
25import Spear.Math.Matrix4 (Matrix4) 25import Spear.Math.Matrix4 (Matrix4)
26import Spear.Math.Vector 26import Spear.Math.Vector
27import Spear.Render.Material 27import Spear.Render.Material
28import Spear.Render.Model 28import Spear.Render.Model
29import Spear.Render.Program 29import Spear.Render.Program
30 30
31import qualified Data.Vector as V 31import qualified Data.Vector as V
32import Unsafe.Coerce (unsafeCoerce) 32import Unsafe.Coerce (unsafeCoerce)
33 33
34data StaticModelResource = StaticModelResource 34data 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
43instance Eq StaticModelResource where 43instance Eq StaticModelResource where
44 m1 == m2 = vao m1 == vao m2 44 m1 == m2 = vao m1 == vao m2
45 45
46instance Ord StaticModelResource where 46instance Ord StaticModelResource where
47 m1 < m2 = vao m1 < vao m2 47 m1 < m2 = vao m1 < vao m2
48 48
49instance ResourceClass StaticModelResource where 49instance ResourceClass StaticModelResource where
50 getResource = rkey 50 getResource = rkey
51 51
52data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } 52data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource }
53 53
54instance Eq StaticModelRenderer where 54instance Eq StaticModelRenderer where
55 m1 == m2 = model m1 == model m2 55 m1 == m2 = model m1 == model m2
56 56
57instance Ord StaticModelRenderer where 57instance 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.
61staticModelResource :: StaticProgramChannels 61staticModelResource :: StaticProgramChannels
62 -> Material 62 -> Material
63 -> Texture 63 -> Texture
64 -> Model 64 -> Model
65 -> Game s StaticModelResource 65 -> Game s StaticModelResource
66 66
67staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do 67staticModelResource (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.
101staticModelRenderer :: StaticModelResource -> StaticModelRenderer 101staticModelRenderer :: StaticModelResource -> StaticModelRenderer
102staticModelRenderer = StaticModelRenderer 102staticModelRenderer = StaticModelRenderer
103 103
104-- | Get the model's ith bounding box. 104-- | Get the model's ith bounding box.
105box :: Int -> StaticModelResource -> Box 105box :: Int -> StaticModelResource -> Box
106box i model = boxes model V.! i 106box i model = boxes model V.! i
107 107
108-- | Get the renderer's model resource. 108-- | Get the renderer's model resource.
109modelRes :: StaticModelRenderer -> StaticModelResource 109modelRes :: StaticModelRenderer -> StaticModelResource
110modelRes = model 110modelRes = model
111 111
112-- | Bind the given renderer to prepare it for rendering. 112-- | Bind the given renderer to prepare it for rendering.
113bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () 113bind :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
114bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = 114bind (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.
123render :: StaticProgramUniforms -> StaticModelRenderer -> IO () 123render :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
124render uniforms (StaticModelRenderer model) = 124render 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.
134mkColsFromStatic 134mkColsFromStatic
135 :: Matrix4 -- ^ Modelview matrix 135 :: Matrix4 -- ^ Modelview matrix
136 -> StaticModelResource 136 -> StaticModelResource
137 -> [Collisioner2] 137 -> [Collisioner2]
138mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) 138mkColsFromStatic 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 @@
1module Spear.Render.Triangle 1module Spear.Render.Triangle
2( 2(
3) 3)
4where 4where
5 5
6 6
7import Spear.GL 7import 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 @@
1module Spear.Scene.GameObject 1module 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)
31where 31where
32 32
33 33
34import Spear.GL 34import Spear.GL
35import Spear.Math.AABB 35import Spear.Math.AABB
36import qualified Spear.Math.Camera as Cam 36import qualified Spear.Math.Camera as Cam
37import Spear.Math.Collision as Col 37import Spear.Math.Collision as Col
38import qualified Spear.Math.Matrix3 as M3 38import qualified Spear.Math.Matrix3 as M3
39import qualified Spear.Math.Matrix4 as M4 39import qualified Spear.Math.Matrix4 as M4
40import Spear.Math.MatrixUtils 40import Spear.Math.MatrixUtils
41import qualified Spear.Math.Spatial2 as S2 41import qualified Spear.Math.Spatial2 as S2
42import qualified Spear.Math.Spatial3 as S3 42import qualified Spear.Math.Spatial3 as S3
43import Spear.Math.Utils 43import Spear.Math.Utils
44import Spear.Math.Vector 44import Spear.Math.Vector
45import qualified Spear.Render.AnimatedModel as AM 45import qualified Spear.Render.AnimatedModel as AM
46import Spear.Render.Program 46import Spear.Render.Program
47import Spear.Render.StaticModel as SM 47import Spear.Render.StaticModel as SM
48 48
49import Data.Fixed (mod') 49import Data.Fixed (mod')
50import Data.List (foldl') 50import Data.List (foldl')
51 51
52 52
53-- | Game style. 53-- | Game style.
54data GameStyle 54data 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
59data Window = Window 59data 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
69dummyWindow = Window M4.id M4.id 0 0 640 480 69dummyWindow = 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.
73data GameObject = GameObject 73data 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
84instance S2.Spatial2 GameObject where 84instance 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.
171goNew :: GameStyle 171goNew :: 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
178goNew style (Left smr) cols transf axis = GameObject 178goNew 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
181goNew style (Right amr) cols transf axis = GameObject 181goNew 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
185goUpdate :: Float -> GameObject -> GameObject 185goUpdate :: Float -> GameObject -> GameObject
186goUpdate dt go = 186goUpdate 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.
207goRPGtransform :: GameObject -> M4.Matrix4 207goRPGtransform :: GameObject -> M4.Matrix4
208goRPGtransform go = 208goRPGtransform 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.
214currentAnimation :: Enum a => GameObject -> a 214currentAnimation :: Enum a => GameObject -> a
215currentAnimation go = case renderer go of 215currentAnimation 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.
221numCollisioners :: GameObject -> Int 221numCollisioners :: GameObject -> Int
222numCollisioners = length . collisioners 222numCollisioners = length . collisioners
223 223
224 224
225-- | Set the game object's current animation. 225-- | Set the game object's current animation.
226setAnimation :: Enum a => a -> GameObject -> GameObject 226setAnimation :: Enum a => a -> GameObject -> GameObject
227setAnimation a go = case renderer go of 227setAnimation 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.
233setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject 233setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject
234setAnimationSpeed s go = case renderer go of 234setAnimationSpeed 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.
240setAxis :: Vector3 -> GameObject -> GameObject 240setAxis :: Vector3 -> GameObject -> GameObject
241setAxis ax go = go { axis = ax } 241setAxis ax go = go { axis = ax }
242 242
243 243
244-- | Set the game object's collisioners. 244-- | Set the game object's collisioners.
245setCollisioners :: [Collisioner2] -> GameObject -> GameObject 245setCollisioners :: [Collisioner2] -> GameObject -> GameObject
246setCollisioners cols go = go { collisioners = cols } 246setCollisioners cols go = go { collisioners = cols }
247 247
248 248
249-- | Set the game object's window. 249-- | Set the game object's window.
250setWindow :: Window -> GameObject -> GameObject 250setWindow :: Window -> GameObject -> GameObject
251setWindow wnd go = go { window = wnd } 251setWindow wnd go = go { window = wnd }
252 252
253 253
254-- | Manipulate the game object's collisioners. 254-- | Manipulate the game object's collisioners.
255withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject 255withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject
256withCollisioners go f = go { collisioners = f $ collisioners go } 256withCollisioners go f = go { collisioners = f $ collisioners go }
257 257
258 258
259-- | Render the game object. 259-- | Render the game object.
260goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO () 260goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO ()
261goRender sprog aprog cam go = 261goRender 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
283type Bind = IO () 283type Bind = IO ()
284 284
285type Render = IO () 285type Render = IO ()
286 286
287 287
288goRender' :: (ProgramUniforms u, Program p) 288goRender' :: (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 ()
300goRender' style a axis prog uniforms modelview proj normal bindRenderer render = 300goRender' 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.
312goCollide :: GameObject -> GameObject -> Bool 312goCollide :: GameObject -> GameObject -> Bool
313goCollide go1 go2 = 313goCollide 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 @@
1module Spear.Scene.Graph 1module 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)
10where 10where
11 11
12 12
13import qualified Data.ByteString.Char8 as B 13import qualified Data.ByteString.Char8 as B
14import Data.List (find, intersperse) 14import Data.List (find, intersperse)
15import Data.Maybe (isJust) 15import Data.Maybe (isJust)
16import Text.Parsec.Char 16import Text.Parsec.Char
17import Text.Parsec.Combinator 17import Text.Parsec.Combinator
18import Text.Parsec.Error 18import Text.Parsec.Error
19import Text.Parsec.Prim 19import Text.Parsec.Prim
20import qualified Text.Parsec.ByteString as P 20import qualified Text.Parsec.ByteString as P
21import qualified Text.Parsec.Token as PT 21import qualified Text.Parsec.Token as PT
22 22
23 23
24type Property = (String, [String]) 24type Property = (String, [String])
25 25
26 26
27data SceneGraph 27data 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
39instance Show SceneGraph where 39instance 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
50printProp :: Property -> String 50printProp :: Property -> String
51printProp (key, vals) = key ++ " = " ++ (concat $ intersperse ", " vals) 51printProp (key, vals) = key ++ " = " ++ (concat $ intersperse ", " vals)
52 52
53 53
54printProps :: String -> [Property] -> String 54printProps :: String -> [Property] -> String
55printProps tab props = 55printProps 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.
75loadSceneGraph :: String -> Either ParseError SceneGraph 75loadSceneGraph :: String -> Either ParseError SceneGraph
76loadSceneGraph str = parse sceneGraph "(unknown)" $ B.pack str 76loadSceneGraph 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.
80loadSceneGraphFromFile :: FilePath -> IO (Either ParseError SceneGraph) 80loadSceneGraphFromFile :: FilePath -> IO (Either ParseError SceneGraph)
81loadSceneGraphFromFile = P.parseFromFile sceneGraph 81loadSceneGraphFromFile = 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.
85node :: String -> SceneGraph -> Maybe SceneGraph 85node :: String -> SceneGraph -> Maybe SceneGraph
86node str SceneLeaf {} = Nothing 86node str SceneLeaf {} = Nothing
87node str n@(SceneNode nid _ children) 87node 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
94sceneGraph :: P.Parser SceneGraph 94sceneGraph :: P.Parser SceneGraph
95sceneGraph = do 95sceneGraph = 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
102graph :: P.Parser SceneGraph 102graph :: P.Parser SceneGraph
103graph = do 103graph = 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
117property :: P.Parser Property 117property :: P.Parser Property
118property = do 118property = 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
125cells :: P.Parser String -> P.Parser [String] 125cells :: P.Parser String -> P.Parser [String]
126cells p = do 126cells 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
132remainingCells :: P.Parser String -> P.Parser [String] 132remainingCells :: P.Parser String -> P.Parser [String]
133remainingCells p = 133remainingCells p =
134 try (whitespace >> char ',' >> whitespace >> cells p) 134 try (whitespace >> char ',' >> whitespace >> cells p)
135 <|> (return []) 135 <|> (return [])
136 136
137 137
138name :: P.Parser String 138name :: P.Parser String
139name = many1 $ choice [oneOf "-/.()?_", alphaNum] 139name = many1 $ choice [oneOf "-/.()?_", alphaNum]
140 140
141 141
142whitespace :: P.Parser () 142whitespace :: P.Parser ()
143whitespace = skipMany $ choice [space, newline] 143whitespace = 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 @@
1module Spear.Scene.Light 1module Spear.Scene.Light
2( 2(
3 Light(..) 3 Light(..)
4) 4)
5where 5where
6 6
7 7
8import qualified Spear.Math.Matrix4 as M 8import qualified Spear.Math.Matrix4 as M
9import qualified Spear.Math.Spatial3 as S 9import qualified Spear.Math.Spatial3 as S
10import Spear.Math.Vector 10import Spear.Math.Vector
11 11
12 12
13data Light 13data 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 @@
1module Spear.Scene.Loader 1module 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)
18where 18where
19 19
20import Spear.Assets.Model as Model 20import Spear.Assets.Model as Model
21import Spear.Game 21import Spear.Game
22import qualified Spear.GL as GL 22import qualified Spear.GL as GL
23import Spear.Math.Collision 23import Spear.Math.Collision
24import Spear.Math.Matrix3 as M3 24import Spear.Math.Matrix3 as M3
25import Spear.Math.Matrix4 as M4 25import Spear.Math.Matrix4 as M4
26import Spear.Math.MatrixUtils (fastNormalMatrix) 26import Spear.Math.MatrixUtils (fastNormalMatrix)
27import Spear.Math.Vector 27import Spear.Math.Vector
28import Spear.Render.AnimatedModel as AM 28import Spear.Render.AnimatedModel as AM
29import Spear.Render.Material 29import Spear.Render.Material
30import Spear.Render.Program 30import Spear.Render.Program
31import Spear.Render.StaticModel as SM 31import Spear.Render.StaticModel as SM
32import Spear.Scene.GameObject as GO 32import Spear.Scene.GameObject as GO
33import Spear.Scene.Graph 33import Spear.Scene.Graph
34import Spear.Scene.Light 34import Spear.Scene.Light
35import Spear.Scene.SceneResources 35import Spear.Scene.SceneResources
36 36
37import Control.Monad.State.Strict 37import Control.Monad.State.Strict
38import Control.Monad.Trans (lift) 38import Control.Monad.Trans (lift)
39import Data.List as L (find) 39import Data.List as L (find)
40import Data.Map as M 40import Data.Map as M
41import qualified Data.StateVar as SV (get) 41import qualified Data.StateVar as SV (get)
42import Text.Printf (printf) 42import Text.Printf (printf)
43 43
44type Loader = Game SceneResources 44type Loader = Game SceneResources
45 45
46-- | Load the scene specified by the given file. 46-- | Load the scene specified by the given file.
47loadScene :: FilePath -> Game s (SceneResources, SceneGraph) 47loadScene :: FilePath -> Game s (SceneResources, SceneGraph)
48loadScene file = do 48loadScene 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.
59validate :: SceneGraph -> Maybe String 59validate :: SceneGraph -> Maybe String
60validate _ = Nothing 60validate _ = Nothing
61 61
62-- | Load the scene described by the given 'SceneGraph'. 62-- | Load the scene described by the given 'SceneGraph'.
63resourceMap :: SceneGraph -> Game s SceneResources 63resourceMap :: SceneGraph -> Game s SceneResources
64resourceMap g = execSubGame (resourceMap' g) emptySceneResources 64resourceMap g = execSubGame (resourceMap' g) emptySceneResources
65 65
66resourceMap' :: SceneGraph -> Loader () 66resourceMap' :: SceneGraph -> Loader ()
67resourceMap' node@(SceneLeaf nid props) = do 67resourceMap' 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
74resourceMap' node@(SceneNode nid props children) = do 74resourceMap' 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.
78loadResource :: String -- ^ Resource name. 78loadResource :: 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
83loadResource key field modifyResources load = do 83loadResource 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
94addShader name shader = modify $ \sceneData -> 94addShader name shader = modify $ \sceneData ->
95 sceneData { shaders = M.insert name shader $ shaders sceneData } 95 sceneData { shaders = M.insert name shader $ shaders sceneData }
96 96
97addCustomProgram name prog = modify $ \sceneData -> 97addCustomProgram name prog = modify $ \sceneData ->
98 sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } 98 sceneData { customPrograms = M.insert name prog $ customPrograms sceneData }
99 99
100addStaticProgram name prog = modify $ \sceneData -> 100addStaticProgram name prog = modify $ \sceneData ->
101 sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } 101 sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData }
102 102
103addAnimatedProgram name prog = modify $ \sceneData -> 103addAnimatedProgram name prog = modify $ \sceneData ->
104 sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } 104 sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData }
105 105
106addTexture name tex = modify $ \sceneData -> 106addTexture name tex = modify $ \sceneData ->
107 sceneData { textures = M.insert name tex $ textures sceneData } 107 sceneData { textures = M.insert name tex $ textures sceneData }
108 108
109addStaticModel name model = modify $ 109addStaticModel 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
112addAnimatedModel name model = modify $ 112addAnimatedModel 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.
116getResource :: (SceneResources -> Map String a) -> String -> Loader a 116getResource :: (SceneResources -> Map String a) -> String -> Loader a
117getResource field key = do 117getResource 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
127newModel :: SceneGraph -> Loader () 127newModel :: SceneGraph -> Loader ()
128newModel (SceneLeaf _ props) = do 128newModel (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
170loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model 170loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model
171loadModel' file rotation scale = do 171loadModel' 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
184rotateModel :: Rotation -> Model -> Model 184rotateModel :: Rotation -> Model -> Model
185rotateModel (Rotation ax ay az order) model = 185rotateModel (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
203loadTexture :: FilePath -> Loader GL.Texture 203loadTexture :: FilePath -> Loader GL.Texture
204loadTexture file = 204loadTexture 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
208newShaderProgram :: SceneGraph -> Loader () 208newShaderProgram :: SceneGraph -> Loader ()
209newShaderProgram (SceneLeaf _ props) = do 209newShaderProgram (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
287loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) 287loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader)
288loadShader _ [] = gameError $ "Loader::vertexShader: empty list" 288loadShader _ [] = gameError $ "Loader::vertexShader: empty list"
289loadShader shaderType ((stype, file):xs) = 289loadShader 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
296loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader 296loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader
297loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file 297loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file
298 298
299newLight :: SceneGraph -> Loader () 299newLight :: SceneGraph -> Loader ()
300newLight _ = return () 300newLight _ = return ()
301 301
302-------------------- 302--------------------
303-- Object Loading -- 303-- Object Loading --
304-------------------- 304--------------------
305 305
306loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject 306loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject
307loadGO style sceneRes props transf = do 307loadGO 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
324type CreateGameObject m a 324type 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'.
332loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] 332loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a]
333loadObjects newGO sceneRes g = 333loadObjects 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.
339newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] 339newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a]
340newObject newGO sceneRes (SceneNode nid props children) = 340newObject 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
344newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] 344newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props]
345 345
346newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a 346newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a
347newObject' newGO sceneRes nid props = do 347newObject' 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
361vectors :: Maybe Vector2 -> (Vector2, Vector2) 361vectors :: Maybe Vector2 -> (Vector2, Vector2)
362vectors up = case up of 362vectors 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.
371value :: String -> [Property] -> Maybe [String] 371value :: String -> [Property] -> Maybe [String]
372value name props = case L.find ((==) name . fst) props of 372value 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
376unspecified :: Maybe a -> a -> a 376unspecified :: Maybe a -> a -> a
377unspecified (Just x) _ = x 377unspecified (Just x) _ = x
378unspecified Nothing x = x 378unspecified Nothing x = x
379 379
380mandatory :: String -> [Property] -> Game s [String] 380mandatory :: String -> [Property] -> Game s [String]
381mandatory name props = case value name props of 381mandatory 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
385mandatory' :: String -> [Property] -> Loader [String] 385mandatory' :: String -> [Property] -> Loader [String]
386mandatory' name props = mandatory name props 386mandatory' name props = mandatory name props
387 387
388asString :: Functor f => f [String] -> f String 388asString :: Functor f => f [String] -> f String
389asString = fmap concat 389asString = fmap concat
390 390
391asFloat :: Functor f => f [String] -> f Float 391asFloat :: Functor f => f [String] -> f Float
392asFloat = fmap (read . concat) 392asFloat = fmap (read . concat)
393 393
394asVec2 :: Functor f => f [String] -> f Vector2 394asVec2 :: Functor f => f [String] -> f Vector2
395asVec2 val = fmap toVec2 val 395asVec2 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
399asVec3 :: Functor f => f [String] -> f Vector3 399asVec3 :: Functor f => f [String] -> f Vector3
400asVec3 val = fmap toVec3 val 400asVec3 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
404asVec4 :: Functor f => f [String] -> f Vector4 404asVec4 :: Functor f => f [String] -> f Vector4
405asVec4 val = fmap toVec4 val 405asVec4 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
409asRotation :: Functor f => f [String] -> f Rotation 409asRotation :: Functor f => f [String] -> f Rotation
410asRotation val = fmap parseRotation val 410asRotation 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
413data Rotation = Rotation 413data 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
420data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq 420data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq
421 421
422readOrder :: String -> RotationOrder 422readOrder :: String -> RotationOrder
423readOrder "xyz" = XYZ 423readOrder "xyz" = XYZ
424readOrder "xzy" = XZY 424readOrder "xzy" = XZY
425readOrder "yxz" = YXZ 425readOrder "yxz" = YXZ
426readOrder "yzx" = YZX 426readOrder "yzx" = YZX
427readOrder "zxy" = ZXY 427readOrder "zxy" = ZXY
428readOrder "zyx" = ZYX 428readOrder "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 @@
1module Spear.Scene.SceneResources 1module 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)
18where 18where
19 19
20import Spear.Assets.Model as Model 20import Spear.Assets.Model as Model
21import Spear.GL as GL 21import Spear.GL as GL
22import Spear.Math.Vector 22import Spear.Math.Vector
23import Spear.Render.AnimatedModel 23import Spear.Render.AnimatedModel
24import Spear.Render.Material 24import Spear.Render.Material
25import Spear.Render.Program 25import Spear.Render.Program
26import Spear.Render.StaticModel 26import Spear.Render.StaticModel
27import Spear.Scene.Light 27import Spear.Scene.Light
28 28
29import Data.Map as M 29import Data.Map as M
30 30
31data SceneResources = SceneResources 31data 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'.
43emptySceneResources = 43emptySceneResources =
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.
47getShader :: SceneResources -> String -> Maybe GLSLShader 47getShader :: SceneResources -> String -> Maybe GLSLShader
48getShader res key = M.lookup key $ shaders res 48getShader 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.
51getCustomProgram :: SceneResources -> String -> Maybe GLSLProgram 51getCustomProgram :: SceneResources -> String -> Maybe GLSLProgram
52getCustomProgram res key = M.lookup key $ customPrograms res 52getCustomProgram 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.
55getStaticProgram :: SceneResources -> String -> Maybe StaticProgram 55getStaticProgram :: SceneResources -> String -> Maybe StaticProgram
56getStaticProgram res key = M.lookup key $ staticPrograms res 56getStaticProgram 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.
59getAnimatedProgram :: SceneResources -> String -> Maybe AnimatedProgram 59getAnimatedProgram :: SceneResources -> String -> Maybe AnimatedProgram
60getAnimatedProgram res key = M.lookup key $ animatedPrograms res 60getAnimatedProgram 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.
63getTexture :: SceneResources -> String -> Maybe Texture 63getTexture :: SceneResources -> String -> Maybe Texture
64getTexture res key = M.lookup key $ textures res 64getTexture 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.
67getStaticModel :: SceneResources -> String -> Maybe StaticModelResource 67getStaticModel :: SceneResources -> String -> Maybe StaticModelResource
68getStaticModel res key = M.lookup key $ staticModels res 68getStaticModel 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.
71getAnimatedModel :: SceneResources -> String -> Maybe AnimatedModelResource 71getAnimatedModel :: SceneResources -> String -> Maybe AnimatedModelResource
72getAnimatedModel res key = M.lookup key $ animatedModels res 72getAnimatedModel 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 @@
1module Spear.Sys.Store 1module 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)
14where 14where
15 15
16 16
17import Data.List as L (find) 17import Data.List as L (find)
18import Data.Maybe (isJust, isNothing) 18import Data.Maybe (isJust, isNothing)
19import Data.Vector as V 19import Data.Vector as V
20import Control.Monad.State -- test 20import Control.Monad.State -- test
21import Text.Printf -- test 21import Text.Printf -- test
22 22
23 23
24type Index = Int 24type Index = Int
25 25
26 26
27data Store a = Store 27data 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
34instance Functor Store where 34instance 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.
39emptyStore :: Store a 39emptyStore :: Store a
40emptyStore = Store V.empty (-1) 40emptyStore = Store V.empty (-1)
41 41
42 42
43-- | Store the given element in the store. 43-- | Store the given element in the store.
44store :: a -> Store a -> (Index, Store a) 44store :: a -> Store a -> (Index, Store a)
45store elem s@(Store objects last) = 45store 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.
55assign :: Index -> a -> Store a -> (Index, Store a) 55assign :: Index -> a -> Store a -> (Index, Store a)
56assign i elem (Store objects last) = 56assign 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.
62storel :: [a] -> Store a -> ([Index], Store a) 62storel :: [a] -> Store a -> ([Index], Store a)
63storel elems s@(Store objects last) = 63storel 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.
77freeSlots :: Vector (Maybe a) -> (Int, Vector Int) 77freeSlots :: Vector (Maybe a) -> (Int, Vector Int)
78freeSlots v = let is = findIndices isNothing v in (V.length is, is) 78freeSlots 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.
83storeInSlots :: Vector Int -> [a] -> Store a -> ([Index], Store a) 83storeInSlots :: Vector Int -> [a] -> Store a -> ([Index], Store a)
84storeInSlots is elems (Store objects last) = 84storeInSlots 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.
93append :: [a] -> Store a -> ([Index], Store a) 93append :: [a] -> Store a -> ([Index], Store a)
94append elems (Store objects last) = 94append 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.
106storeFree :: Index -> Store a -> Store a 106storeFree :: Index -> Store a -> Store a
107storeFree i (Store objects last) = 107storeFree 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
117findLastIndex :: (a -> Bool) -> Vector a -> Maybe Index 117findLastIndex :: (a -> Bool) -> Vector a -> Maybe Index
118findLastIndex p v = findLastIndex' p v Nothing 0 118findLastIndex 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.
127storeFreel :: [Index] -> Store a -> Store a 127storeFreel :: [Index] -> Store a -> Store a
128storeFreel is (Store objects last) = 128storeFreel 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.
140element :: Index -> Store a -> Maybe a 140element :: Index -> Store a -> Maybe a
141element index (Store objects _) = objects V.! index 141element 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.
145setElement :: Index -> a -> Store a -> Store a 145setElement :: Index -> a -> Store a -> Store a
146setElement index elem s = s { objects = objects s // [(index,Just elem)] } 146setElement 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.
150withElement :: Index -> Store a -> (a -> a) -> Store a 150withElement :: Index -> Store a -> (a -> a) -> Store a
151withElement index store f = store { objects = objects' } 151withElement 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
160test :: IO () 160test :: IO ()
161test = evalStateT test' emptyStore 161test = evalStateT test' emptyStore
162 162
163 163
164test' :: StateT (Store Int) IO () 164test' :: StateT (Store Int) IO ()
165test' = do 165test' = 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
180store' :: Int -> StateT (Store Int) IO Int 180store' :: Int -> StateT (Store Int) IO Int
181store' elem = do 181store' 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
189free :: Index -> StateT (Store Int) IO () 189free :: Index -> StateT (Store Int) IO ()
190free i = do 190free 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 @@
1module Spear.Sys.Store.ID 1module 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)
9where 9where
10 10
11 11
12import Data.Vector.Unboxed as U 12import Data.Vector.Unboxed as U
13import Control.Monad.State -- test 13import Control.Monad.State -- test
14import Text.Printf -- test 14import Text.Printf -- test
15 15
16 16
17type ID = Int 17type ID = Int
18 18
19 19
20data IDStore = IDStore 20data 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.
28emptyIDStore :: IDStore 28emptyIDStore :: IDStore
29emptyIDStore = IDStore U.empty (-1) 29emptyIDStore = IDStore U.empty (-1)
30 30
31 31
32-- | Request an ID from the ID store. 32-- | Request an ID from the ID store.
33newID :: IDStore -> (ID, IDStore) 33newID :: IDStore -> (ID, IDStore)
34newID store@(IDStore assigned last) = 34newID 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.
44assign :: ID -> IDStore -> (ID, IDStore) 44assign :: ID -> IDStore -> (ID, IDStore)
45assign i (IDStore assigned last) = 45assign 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.
51freeID :: ID -> IDStore -> IDStore 51freeID :: ID -> IDStore -> IDStore
52freeID i (IDStore assigned last) = 52freeID 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
62findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int 62findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int
63findLastIndex p v = findLastIndex' p v Nothing 0 63findLastIndex 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
72test :: IO () 72test :: IO ()
73test = evalStateT test' emptyIDStore 73test = evalStateT test' emptyIDStore
74 74
75 75
76test' :: StateT IDStore IO () 76test' :: StateT IDStore IO ()
77test' = do 77test' = 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
92request :: StateT IDStore IO ID 92request :: StateT IDStore IO ID
93request = do 93request = 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
101free :: ID -> StateT IDStore IO () 101free :: ID -> StateT IDStore IO ()
102free i = do 102free 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" #-}
5module 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)
19where
20
21
22import Foreign
23import Foreign.C.Types
24import Control.Monad
25import System.IO.Unsafe
26
27
28
29{-# LINE 28 "Timer.hsc" #-}
30type TimeReading = CDouble
31
32{-# LINE 30 "Timer.hsc" #-}
33
34data 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
49instance 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
88foreign import ccall "Timer.h timer_initialise_subsystem"
89 c_timer_initialise_subsystem :: IO ()
90
91foreign import ccall "Timer.h timer_initialise_timer"
92 c_timer_initialise_timer :: Ptr Timer -> IO ()
93
94foreign import ccall "Timer.h timer_tick"
95 c_timer_tick :: Ptr Timer -> IO ()
96
97foreign import ccall "Timer.h timer_reset"
98 c_timer_reset :: Ptr Timer -> IO ()
99
100foreign import ccall "Timer.h timer_stop"
101 c_timer_stop :: Ptr Timer -> IO ()
102
103foreign import ccall "Timer.h timer_start"
104 c_timer_start :: Ptr Timer -> IO ()
105
106foreign import ccall "Timer.h timer_sleep"
107 c_timer_sleep :: CFloat -> IO ()
108
109foreign import ccall "Timer.h timer_get_time"
110 c_timer_get_time :: Ptr Timer -> IO (CFloat)
111
112foreign import ccall "Timer.h timer_get_delta"
113 c_timer_get_delta :: Ptr Timer -> IO (CFloat)
114
115foreign import ccall "Timer.h timer_is_running"
116 c_timer_is_running :: Ptr Timer -> IO (CChar)
117
118
119-- | Initialises the timing subsystem.
120initialiseTimingSubsystem :: IO ()
121initialiseTimingSubsystem = c_timer_initialise_subsystem
122
123
124-- | Creates a timer.
125newTimer :: Timer
126newTimer = unsafePerformIO . alloca $ \tptr -> do
127 c_timer_initialise_timer tptr
128 t <- peek tptr
129 return t
130
131
132-- | Updates the timer.
133tick :: Timer -> IO (Timer)
134tick 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.
142reset :: Timer -> IO (Timer)
143reset 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.
151stop :: Timer -> IO (Timer)
152stop 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.
160start :: Timer -> IO (Timer)
161start 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.
169sleep :: Float -> IO ()
170sleep = c_timer_sleep . realToFrac
171
172
173-- | Gets the timer's total running time.
174getTime :: Timer -> Float
175getTime 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.
182getDelta :: Timer -> Float
183getDelta 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.
190isRunning :: Timer -> Bool
191isRunning 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 #-}
2module Spear.Sys.Timer 2module 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) 15where
16where 16
17 17import Foreign.C.Types
18 18import Foreign.Marshal.Alloc (alloca)
19import Foreign hiding (unsafePerformIO) 19import Foreign.Ptr
20import Foreign.C.Types 20import Foreign.Storable
21import Control.Monad 21import Control.Monad
22import System.IO.Unsafe 22import System.IO.Unsafe
23 23
24 24#ifdef WIN32
25#ifdef WIN32 25type TimeReading = CULLong
26type TimeReading = CULLong 26#else
27#else 27type TimeReading = CDouble
28type TimeReading = CDouble 28#endif
29#endif 29
30 30data Timer = Timer
31data 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" 42instance Storable Timer where
43 43 sizeOf _ = #{size Timer}
44 44 alignment _ = alignment (undefined :: TimeReading)
45instance 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 65foreign import ccall unsafe "Timer.h timer_init"
66 #{poke timer, stopped} ptr stopped 66 c_timer_init :: Ptr Timer -> IO ()
67 67
68 68foreign import ccall unsafe "Timer.h timer_tick"
69foreign import ccall "Timer.h timer_initialise_subsystem" 69 c_timer_tick :: Ptr Timer -> IO ()
70 c_timer_initialise_subsystem :: IO () 70
71 71foreign import ccall unsafe "Timer.h timer_start"
72foreign import ccall "Timer.h timer_initialise_timer" 72 c_timer_start :: Ptr Timer -> IO ()
73 c_timer_initialise_timer :: Ptr Timer -> IO () 73
74 74foreign import ccall unsafe "Timer.h timer_stop"
75foreign import ccall "Timer.h timer_tick" 75 c_timer_stop :: Ptr Timer -> IO ()
76 c_timer_tick :: Ptr Timer -> IO () 76
77 77foreign import ccall unsafe "Timer.h timer_reset"
78foreign import ccall "Timer.h timer_reset" 78 c_timer_reset :: Ptr Timer -> IO ()
79 c_timer_reset :: Ptr Timer -> IO () 79
80 80foreign import ccall unsafe "Timer.h timer_get_time"
81foreign import ccall "Timer.h timer_stop" 81 c_timer_get_time :: Ptr Timer -> IO (CDouble)
82 c_timer_stop :: Ptr Timer -> IO () 82
83 83foreign import ccall unsafe "Timer.h timer_get_delta"
84foreign import ccall "Timer.h timer_start" 84 c_timer_get_delta :: Ptr Timer -> IO (CFloat)
85 c_timer_start :: Ptr Timer -> IO () 85
86 86foreign import ccall unsafe "Timer.h timer_is_running"
87foreign import ccall "Timer.h timer_sleep" 87 c_timer_is_running :: Ptr Timer -> IO (CChar)
88 c_timer_sleep :: CFloat -> IO () 88
89 89foreign import ccall "Timer.h timer_sleep"
90foreign 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.
93foreign import ccall "Timer.h timer_get_delta" 93newTimer :: Timer
94 c_timer_get_delta :: Ptr Timer -> IO (CFloat) 94newTimer = unsafePerformIO . unsafeInterleaveIO . alloca $ \tptr -> do
95 95 c_timer_init tptr
96foreign 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 99tick :: Timer -> IO (Timer)
100-- | Initialises the timing subsystem. 100tick t = alloca $ \tptr -> do
101initialiseTimingSubsystem :: IO () 101 poke tptr t
102initialiseTimingSubsystem = c_timer_initialise_subsystem 102 c_timer_tick tptr
103 103 peek tptr
104 104
105-- | Creates a timer. 105-- | Start the timer.
106newTimer :: Timer 106start :: Timer -> IO (Timer)
107newTimer = unsafePerformIO . alloca $ \tptr -> do 107start 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.
114tick :: Timer -> IO (Timer) 114stop :: Timer -> IO (Timer)
115tick t = alloca $ \tptr -> do 115stop 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 121reset :: Timer -> IO (Timer)
122-- | Resets the timer. 122reset t = alloca $ \tptr -> do
123reset :: Timer -> IO (Timer) 123 poke tptr t
124reset 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' 128getTime :: Timer -> Double
129 129getTime t = unsafeDupablePerformIO . alloca $ \tptr -> do
130 130 poke tptr t
131-- | Stops the timer. 131 time <- c_timer_get_time tptr
132stop :: Timer -> IO (Timer) 132 return (realToFrac time)
133stop t = alloca $ \tptr -> do 133
134 poke tptr t 134-- | Get the time elapsed between the last two ticks.
135 c_timer_stop tptr 135getDelta :: Timer -> Float
136 t' <- peek tptr 136getDelta 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
141start :: Timer -> IO (Timer) 141-- | Return true if the timer is running (not stopped), false otherwise.
142start t = alloca $ \tptr -> do 142isRunning :: Timer -> Bool
143 poke tptr t 143isRunning 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. 149sleep :: Float -> IO ()
150sleep :: Float -> IO () 150sleep = c_timer_sleep . realToFrac
151sleep = c_timer_sleep . realToFrac
152
153
154-- | Gets the timer's total running time.
155getTime :: Timer -> Float
156getTime 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.
163getDelta :: Timer -> Float
164getDelta 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.
171isRunning :: Timer -> Bool
172isRunning 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 5typedef __int64 timeReading;
6 #define DECLDIR __declspec(dllexport)
7 #else
8 #define DECLDIR __declspec(dllimport)
9 #endif
10#else 6#else
11 #define DECLDIR 7typedef __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; 10typedef __UINT64_TYPE__ timeReading;
22#endif 11#endif
23 12
24#ifdef __cplusplus 13#ifdef __cplusplus
25extern C { 14extern "C" {
26#endif 15#endif
27 16
17/*
18 Header: Timer
19 A high resolution timer module.
20*/
21
22/*
23 Struct: Timer
24*/
28typedef struct 25typedef 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*/
49void timer_init (Timer*);
38 50
39/// Initialises the timing subsystem. 51/*
40void 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
43void 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.
46void DECLDIR timer_tick (timer* t); 60*/
61void timer_tick (Timer*);
47 62
48/// Call before message loop. 63/*
49void 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
52void 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;
55void DECLDIR timer_start (timer* t); 71 it's only a mechanism to resume a stopped timer.
72*/
73void timer_start (Timer*);
56 74
57/// Puts the caller thread to sleep for the given number of seconds. 75/*
58void 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
61float 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().
64float DECLDIR timer_get_delta (timer* t); 84*/
85void timer_stop (Timer*);
65 86
66/// Gets the timer's running state. 87/*
67char 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*/
98void 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*/
107double 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*/
114float 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*/
120char 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*/
126void 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
16static double secondsPerCount; 16static double secondsPerCount;
17 17
18 18static void timer_initialise_subsystem ()
19void 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} 31static timeReading now ()
32 32{
33 33 timeReading t;
34timeReading 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 46void timer_init (Timer* timer)
47 47{
48 return t; 48 timer_initialise_subsystem();
49} 49 timer_reset (timer);
50 50}
51 51
52void DECLDIR timer_initialise_timer (timer* t) 52void 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.
64void 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. 78void 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 90void timer_stop (Timer* timer)
91void 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 }
101void timer_stop (timer* t) 101}
102{ 102
103 // Don't do anything if we are already stopped. 103void 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;
115void 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. 122double 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 }
135void timer_sleep (float seconds) 135}
136{ 136
137#ifdef WIN32 137float 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; 142char timer_is_running (const Timer* timer)
143 nanosleep(&ts, NULL); 143{
144#endif 144 return !timer->stopped;
145} 145}
146 146
147 147void timer_sleep (float seconds)
148float 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
163float timer_get_delta (timer* t)
164{
165 return t->deltaTime;
166}
167
168
169char timer_is_running (timer* t)
170{
171 return !t->stopped;
172}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-25 00:13:34 +0000