From 7360483ecb4e783566968b9a88e0cf3d3b4bd6c0 Mon Sep 17 00:00:00 2001 From: Jeanne-Kamikaze Date: Fri, 10 May 2013 16:10:28 +0200 Subject: Game tweaks; fixed GLFW terminate bug --- LICENSE | 14 +- README.md | 96 +-- Setup.hs | 4 +- Spear.cabal | 216 ++--- Spear/App.hs | 20 +- Spear/App/Application.hs | 268 +++--- Spear/App/Input.hs | 530 ++++++------ Spear/Assets/Image.hsc | 252 +++--- Spear/Assets/Image/Image.c | 16 +- Spear/Assets/Image/Image.h | 64 +- Spear/Assets/Image/Image_error_code.h | 30 +- Spear/Assets/Image/sys_types.h | 32 +- Spear/Assets/Model.hsc | 880 ++++++++++---------- Spear/Assets/Model/MD2/MD2_load.c | 960 +++++++++++----------- Spear/Assets/Model/Model.c | 224 ++--- Spear/Assets/Model/Model.h | 200 ++--- Spear/Assets/Model/Model_error_code.h | 32 +- Spear/Assets/Model/OBJ/Makefile | 30 +- Spear/Assets/Model/OBJ/OBJ_load.c | 548 ++++++------- Spear/Assets/Model/OBJ/OBJ_load.h | 50 +- Spear/Assets/Model/OBJ/cvector.c | 180 ++-- Spear/Assets/Model/OBJ/cvector.h | 72 +- Spear/Assets/Model/sys_types.h | 32 +- Spear/GL.hs | 1449 +++++++++++++++++---------------- Spear/Game.hs | 199 ++--- Spear/Math/AABB.hs | 80 +- Spear/Math/Camera.hs | 150 ++-- Spear/Math/Circle.hs | 52 +- Spear/Math/Collision.hs | 482 +++++------ Spear/Math/Entity.hs | 66 +- Spear/Math/Frustum.hs | 56 +- Spear/Math/Matrix3.hs | 670 +++++++-------- Spear/Math/Matrix4.hs | 1300 ++++++++++++++--------------- Spear/Math/MatrixUtils.hs | 300 +++---- Spear/Math/Octree.hs | 456 +++++------ Spear/Math/Physics.hs | 18 +- Spear/Math/Physics/Rigid.hs | 250 +++--- Spear/Math/Physics/Types.hs | 22 +- Spear/Math/Plane.hs | 78 +- Spear/Math/Quaternion.hs | 216 ++--- Spear/Math/Ray.hs | 62 +- Spear/Math/Segment.hs | 42 +- Spear/Math/Spatial2.hs | 150 ++-- Spear/Math/Spatial3.hs | 322 ++++---- Spear/Math/Sphere.hs | 52 +- Spear/Math/Triangle.hs | 80 +- Spear/Math/Utils.hs | 76 +- Spear/Math/Vector.hs | 26 +- Spear/Math/Vector/Class.hs | 84 +- Spear/Math/Vector/Vector2.hs | 260 +++--- Spear/Math/Vector/Vector3.hs | 368 ++++----- Spear/Math/Vector/Vector4.hs | 332 ++++---- Spear/Render/AnimatedModel.hs | 470 +++++------ Spear/Render/Box.hs | 384 ++++----- Spear/Render/Material.hs | 32 +- Spear/Render/Model.hsc | 108 +-- Spear/Render/Program.hs | 204 ++--- Spear/Render/RenderModel.c | 464 +++++------ Spear/Render/RenderModel.h | 98 +-- Spear/Render/Sphere.hs | 88 +- Spear/Render/StaticModel.hs | 276 +++---- Spear/Render/Triangle.hs | 16 +- Spear/Scene/GameObject.hs | 640 +++++++-------- Spear/Scene/Graph.hs | 286 +++---- Spear/Scene/Light.hs | 62 +- Spear/Scene/Loader.hs | 856 +++++++++---------- Spear/Scene/SceneResources.hs | 144 ++-- Spear/Sys/Store.hs | 390 ++++----- Spear/Sys/Store/ID.hs | 212 ++--- Spear/Sys/Timer.hs | 194 ----- Spear/Sys/Timer.hsc | 325 ++++---- Spear/Sys/Timer/Timer.h | 155 ++-- Spear/Sys/Timer/ctimer.c | 329 ++++---- 73 files changed, 9017 insertions(+), 9164 deletions(-) delete mode 100644 Spear/Sys/Timer.hs diff --git a/LICENSE b/LICENSE index 914c31a..037be14 100644 --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -Copyright (c) 2012 Marc Sunet - -Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +Copyright (c) 2012 Marc Sunet + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md index b1c470b..3724fe9 100644 --- a/README.md +++ b/README.md @@ -1,48 +1,48 @@ -Spear -===== - -Spear is a simple 2.5D game engine I have been working on since I started learning Haskell. -The project's goal is to put what I learn into practise, to explore how far I can get with Haskell and if the results -are decent enough, to build one or two game demos along the way. - -Installation ------------- - -Simply clone the repo and build with cabal: - -``` -$ git clone https://github.com/jeannekamikaze/Spear.git -$ cd Spear -$ cabal install -``` - -Features --------- - -### Application and Input -* Easy way to set up a window with the desired OpenGL context version. -* Raw polled, toggled and delayed input. -* High resolution timer. - -### Assets -* MD2 and OBJ model loaders. -* BMP image loader. -* Assets backed up by Resource for automatic (and optionally, manual) deletion. - -### Collision -* Simple collision library featuring AABBs and bounding circles. - -### OpenGL -* OpenGL >=3 wrapper library. -* OpenGL resources (VAOs, buffers, textures, etc.) backed up by Resource for automatic (and optionally, manual) deletion. - -### Math -* Vectors, matrices, quaternions, cameras, segments, rays, etc. -* The Spatial2 and Spatial3 type classes for objects that can be moved around in 2D and 3D space, respectively. - -### Render -* Static and vertex-animated model resources, compiled into a VAO for efficient rendering. -* Static and vertex-animated model renderers. Vertex animation is done in a vertex shader. - -### Scene -* Automated loading of scenes and scene resources as described by scene files. +Spear +===== + +Spear is a simple 2.5D game engine I have been working on since I started learning Haskell. +The project's goal is to put what I learn into practise, to explore how far I can get with Haskell and if the results +are decent enough, to build one or two game demos along the way. + +Installation +------------ + +Simply clone the repo and build with cabal: + +``` +$ git clone https://github.com/jeannekamikaze/Spear.git +$ cd Spear +$ cabal install +``` + +Features +-------- + +### Application and Input +* Easy way to set up a window with the desired OpenGL context version. +* Raw polled, toggled and delayed input. +* High resolution timer. + +### Assets +* MD2 and OBJ model loaders. +* BMP image loader. +* Assets backed up by Resource for automatic (and optionally, manual) deletion. + +### Collision +* Simple collision library featuring AABBs and bounding circles. + +### OpenGL +* OpenGL >=3 wrapper library. +* OpenGL resources (VAOs, buffers, textures, etc.) backed up by Resource for automatic (and optionally, manual) deletion. + +### Math +* Vectors, matrices, quaternions, cameras, segments, rays, etc. +* The Spatial2 and Spatial3 type classes for objects that can be moved around in 2D and 3D space, respectively. + +### Render +* Static and vertex-animated model resources, compiled into a VAO for efficient rendering. +* Static and vertex-animated model renderers. Vertex animation is done in a vertex shader. + +### Scene +* 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 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/Spear.cabal b/Spear.cabal index e25b347..0e52faf 100644 --- a/Spear.cabal +++ b/Spear.cabal @@ -1,108 +1,108 @@ -name: Spear -version: 0.1 -cabal-version: >=1.2 -build-type: Simple -license: BSD3 -license-file: LICENSE -maintainer: jeannekamikaze@gmail.com -homepage: http://spear.shellblade.net -synopsis: A 2.5D game framework. -category: Game -author: Marc Sunet -data-dir: "" - -library - build-depends: GLFW -any, - OpenGL -any, - OpenGLRaw -any, - StateVar -any, - base -any, - bytestring >= 0.10, - directory -any, - mtl -any, - transformers -any, - resourcet -any, - parsec >= 3, - containers -any, - vector -any, - array -any - - exposed-modules: Spear.App - Spear.App.Application - Spear.App.Input - Spear.Assets.Image - Spear.Assets.Model - Spear.Game - Spear.GL - Spear.Math.AABB - Spear.Math.Camera - Spear.Math.Circle - Spear.Math.Collision - Spear.Math.Entity - Spear.Math.Frustum - Spear.Math.Matrix3 - Spear.Math.Matrix4 - Spear.Math.MatrixUtils - Spear.Math.Octree - Spear.Math.Plane - Spear.Math.Quaternion - Spear.Math.Ray - Spear.Math.Segment - Spear.Math.Spatial2 - Spear.Math.Spatial3 - Spear.Math.Triangle - Spear.Math.Utils - Spear.Math.Vector - Spear.Math.Vector.Class - Spear.Math.Vector.Vector2 - Spear.Math.Vector.Vector3 - Spear.Math.Vector.Vector4 - Spear.Render.AnimatedModel - Spear.Render.Material - Spear.Render.Model - Spear.Render.Program - Spear.Render.StaticModel - Spear.Scene.GameObject - Spear.Scene.Graph - Spear.Scene.Light - Spear.Scene.Loader - Spear.Scene.SceneResources - Spear.Sys.Store - Spear.Sys.Store.ID - Spear.Sys.Timer - - exposed: True - - buildable: True - - build-tools: hsc2hs -any - - cc-options: -O2 -g -Wno-unused-result - - c-sources: Spear/Assets/Image/Image.c - Spear/Assets/Image/BMP/BMP_load.c - Spear/Assets/Model/Model.c - Spear/Assets/Model/MD2/MD2_load.c - Spear/Assets/Model/OBJ/cvector.c - Spear/Assets/Model/OBJ/OBJ_load.c - Spear/Render/RenderModel.c - Spear/Sys/Timer/ctimer.c - - extensions: TypeFamilies - - includes: Spear/Assets/Image/BMP/BMP_load.h - Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h - Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h - Spear/Assets/Model/OBJ/OBJ_load.h Spear/Assets/Model/OBJ/cvector.h - Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h - Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h - Timer/Timer.h - - include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render - Spear/Sys - - hs-source-dirs: . - - ghc-options: -O2 - - ghc-prof-options: -O2 -rtsopts -fprof-auto -fprof-cafs +name: Spear +version: 0.1 +cabal-version: >=1.2 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: jeannekamikaze@gmail.com +homepage: http://spear.shellblade.net +synopsis: A 2.5D game framework. +category: Game +author: Marc Sunet +data-dir: "" + +library + build-depends: GLFW -any, + OpenGL -any, + OpenGLRaw -any, + StateVar -any, + base -any, + bytestring >= 0.10, + directory -any, + mtl -any, + transformers -any, + resourcet -any, + parsec >= 3, + containers -any, + vector -any, + array -any + + exposed-modules: Spear.App + Spear.App.Application + Spear.App.Input + Spear.Assets.Image + Spear.Assets.Model + Spear.Game + Spear.GL + Spear.Math.AABB + Spear.Math.Camera + Spear.Math.Circle + Spear.Math.Collision + Spear.Math.Entity + Spear.Math.Frustum + Spear.Math.Matrix3 + Spear.Math.Matrix4 + Spear.Math.MatrixUtils + Spear.Math.Octree + Spear.Math.Plane + Spear.Math.Quaternion + Spear.Math.Ray + Spear.Math.Segment + Spear.Math.Spatial2 + Spear.Math.Spatial3 + Spear.Math.Triangle + Spear.Math.Utils + Spear.Math.Vector + Spear.Math.Vector.Class + Spear.Math.Vector.Vector2 + Spear.Math.Vector.Vector3 + Spear.Math.Vector.Vector4 + Spear.Render.AnimatedModel + Spear.Render.Material + Spear.Render.Model + Spear.Render.Program + Spear.Render.StaticModel + Spear.Scene.GameObject + Spear.Scene.Graph + Spear.Scene.Light + Spear.Scene.Loader + Spear.Scene.SceneResources + Spear.Sys.Store + Spear.Sys.Store.ID + Spear.Sys.Timer + + exposed: True + + buildable: True + + build-tools: hsc2hs -any + + cc-options: -O2 -g -Wno-unused-result + + c-sources: Spear/Assets/Image/Image.c + Spear/Assets/Image/BMP/BMP_load.c + Spear/Assets/Model/Model.c + Spear/Assets/Model/MD2/MD2_load.c + Spear/Assets/Model/OBJ/cvector.c + Spear/Assets/Model/OBJ/OBJ_load.c + Spear/Render/RenderModel.c + Spear/Sys/Timer/ctimer.c + + extensions: TypeFamilies + + includes: Spear/Assets/Image/BMP/BMP_load.h + Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h + Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h + Spear/Assets/Model/OBJ/OBJ_load.h Spear/Assets/Model/OBJ/cvector.h + Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h + Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h + Timer/Timer.h + + include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render + Spear/Sys + + hs-source-dirs: . + + ghc-options: -O2 + + 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 @@ -module Spear.App -( - module Spear.App.Application -, module Spear.App.Input -) -where - - -import Spear.App.Application -import Spear.App.Input +module Spear.App +( + module Spear.App.Application +, module Spear.App.Input +) +where + + +import Spear.App.Application +import Spear.App.Input diff --git a/Spear/App/Application.hs b/Spear/App/Application.hs index ce52f0d..8f1e726 100644 --- a/Spear/App/Application.hs +++ b/Spear/App/Application.hs @@ -1,125 +1,143 @@ -module Spear.App.Application -( - -- * Setup - Dimensions -, Context -, SpearWindow -, Update -, Size(..) -, DisplayBits(..) -, WindowMode(..) -, WindowSizeCallback -, setup -, quit - -- * Main loop -, loop -, loopCapped - -- * Helpers -, swapBuffers -, getParam -, SpecialFeature(..) -, enableSpecial -, disableSpecial -) -where - -import Spear.Game -import Spear.Sys.Timer as Timer - -import Control.Applicative -import Control.Monad (forever, when) -import Control.Monad.Trans.Error -import Control.Monad.Trans.Class (lift) -import Graphics.UI.GLFW as GLFW -import Graphics.Rendering.OpenGL as GL -import System.Exit -import Unsafe.Coerce - --- | Window dimensions. -type Dimensions = (Int, Int) - --- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). -type Context = (Int, Int) - --- | Represents a window. -newtype SpearWindow = SpearWindow { rkey :: Resource } - -instance ResourceClass SpearWindow where - getResource = rkey - --- | Set up an application 'SpearWindow'. -setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context - -> WindowSizeCallback -> Game s SpearWindow -setup (w, h) displayBits windowMode (major, minor) onResize' = do - glfwInit - gameIO $ do - openWindowHint OpenGLVersionMajor major - openWindowHint OpenGLVersionMinor minor - disableSpecial AutoPollEvent - - let dimensions = GL.Size (unsafeCoerce w) (unsafeCoerce h) - result <- openWindow dimensions displayBits windowMode - windowTitle $= "Spear Game Framework" - GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) - - windowSizeCallback $= (onResize onResize') - onResize' (Size (fromIntegral w) (fromIntegral h)) - - initialiseTimingSubsystem - - rkey <- register quit - return $ SpearWindow rkey - -glfwInit :: Game s () -glfwInit = do - result <- gameIO GLFW.initialize - case result of - False -> gameError "GLFW.initialize failed" - True -> return () - --- | Close the application's window. -quit :: IO () -quit = GLFW.terminate - --- | Return true if the application should continue running, false otherwise. -type Update s = Float -> Game s (Bool) - --- | Run the application's main loop. -loop :: Update s -> Game s () -loop update = do - timer <- gameIO $ start newTimer - run timer update - -run :: Timer -> Update s -> Game s () -run timer update = do - timer' <- gameIO $ tick timer - continue <- update $ getDelta timer' - opened <- gameIO $ getParam Opened - case continue && opened of - False -> return () - True -> run timer' update - --- | Run the application's main loop, with a limit on the frame rate. -loopCapped :: Int -> Update s -> Game s () -loopCapped maxFPS update = do - let ddt = 1.0 / (fromIntegral maxFPS) - timer <- gameIO $ start newTimer - runCapped ddt timer update - -runCapped :: Float -> Timer -> Update s -> Game s () -runCapped ddt timer update = do - timer' <- gameIO $ tick timer - continue <- update $ getDelta timer' - opened <- gameIO $ getParam Opened - case continue && opened of - False -> return () - True -> do - t'' <- gameIO $ tick timer' - let dt = getDelta t'' - when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) - runCapped ddt timer' update - -onResize :: WindowSizeCallback -> Size -> IO () -onResize callback s@(Size w h) = do - GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) - callback s +module Spear.App.Application +( + -- * Setup + Dimensions +, Context +, WindowTitle +, SpearWindow +, Update +, Size(..) +, DisplayBits(..) +, WindowMode(..) +, WindowSizeCallback +, withWindow + -- * Main loop +, loop +, loopCapped + -- * Helpers +, swapBuffers +) +where + +import Spear.Game +import Spear.Sys.Timer as Timer + +import Control.Concurrent.MVar +import Control.Monad (when) +import Graphics.UI.GLFW as GLFW +import Graphics.Rendering.OpenGL as GL + +-- | Window dimensions. +type Dimensions = (Int, Int) + +-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). +type Context = (Int, Int) + +type WindowTitle = String + +-- Whether the user has closed the window. +type CloseRequested = MVar Bool + +-- | Represents a window. +data SpearWindow = SpearWindow + { closeRequest :: CloseRequested + } + +withWindow :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle + -> WindowSizeCallback -> (SpearWindow -> Game s a) -> Game s a +withWindow dim displayBits windowMode glVersion windowTitle onResize run = do + glfwInit + window <- setup dim displayBits windowMode glVersion windowTitle onResize + gs <- getGameState + (a,s) <- runSubGame (run window) gs + gameIO GLFW.closeWindow + gameIO GLFW.terminate + saveGameState s + return a + +-- Set up an application 'SpearWindow'. +setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle + -> WindowSizeCallback -> Game s SpearWindow +setup (w, h) displayBits windowMode (major, minor) wndTitle onResize' = do + closeRequest <- gameIO $ newEmptyMVar + gameIO $ do + openWindowHint OpenGLVersionMajor major + openWindowHint OpenGLVersionMinor minor + openWindowHint OpenGLProfile OpenGLCompatProfile + disableSpecial AutoPollEvent + + let dimensions = GL.Size (fromIntegral w) (fromIntegral h) + result <- openWindow dimensions displayBits windowMode + windowTitle $= case wndTitle of + Nothing -> "Spear Game Framework" + Just title -> title + GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) + + windowSizeCallback $= (onResize onResize') + windowCloseCallback $= (onWindowClose closeRequest) + onResize' (Size (fromIntegral w) (fromIntegral h)) + + return $ SpearWindow closeRequest + +glfwInit :: Game s () +glfwInit = do + result <- gameIO GLFW.initialize + case result of + False -> gameError "GLFW.initialize failed" + True -> return () + +-- | Return true if the application should continue running, false otherwise. +type Update s = Float -> Game s (Bool) + +-- | Run the application's main loop. +loop :: SpearWindow -> Update s -> Game s () +loop wnd update = do + gs <- getGameState + flip runSubGame gs $ do + timer <- gameIO $ start newTimer + run (closeRequest wnd) timer update + return () + +run :: CloseRequested -> Timer -> Update s -> Game s () +run closeRequest timer update = do + timer' <- gameIO $ tick timer + continue <- update $ getDelta timer' + close <- gameIO $ getRequest closeRequest + when (continue && (not close)) $ run closeRequest timer' update + +-- | Run the application's main loop with a limit on the frame rate. +loopCapped :: SpearWindow -> Int -> Update s -> Game s () +loopCapped wnd maxFPS update = do + gs <- getGameState + flip runSubGame gs $ do + let ddt = 1.0 / (fromIntegral maxFPS) + closeReq = closeRequest wnd + frameTimer <- gameIO $ start newTimer + controlTimer <- gameIO $ start newTimer + runCapped closeReq ddt frameTimer controlTimer update + return () + +runCapped :: CloseRequested -> Float -> Timer -> Timer -> Update s -> Game s () +runCapped closeRequest ddt frameTimer controlTimer update = do + controlTimer' <- gameIO $ tick controlTimer + frameTimer' <- gameIO $ tick frameTimer + continue <- update $ getDelta frameTimer' + close <- gameIO $ getRequest closeRequest + controlTimer'' <- gameIO $ tick controlTimer' + let dt = getDelta controlTimer'' + when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) + when (continue && (not close)) $ + runCapped closeRequest ddt frameTimer' controlTimer'' update + +getRequest :: MVar Bool -> IO Bool +getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of + Nothing -> False + Just x -> x + +onResize :: WindowSizeCallback -> Size -> IO () +onResize callback s@(Size w h) = do + GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) + callback s + +onWindowClose :: MVar Bool -> WindowCloseCallback +onWindowClose closeRequest = putMVar closeRequest True >> return False diff --git a/Spear/App/Input.hs b/Spear/App/Input.hs index d49a3f7..3a4fc99 100644 --- a/Spear/App/Input.hs +++ b/Spear/App/Input.hs @@ -1,265 +1,265 @@ -module Spear.App.Input -( - -- * Data types - Key(..) -, MouseButton(..) -, MouseProp(..) -, Keyboard -, Mouse(..) -, Input(..) -, ButtonDelay -, DelayedMouse - -- * Input state querying -, newKeyboard -, getKeyboard -, newMouse -, getMouse -, newInput -, getInput -, pollInput - -- * Toggled input -, toggledMouse -, toggledKeyboard - -- * Delayed input -, newDM -, updateDM -, delayedMouse - -- * Input modifiers -, setMousePosition -, setMouseWheel -) -where - -import Data.Char (ord) -import qualified Data.Vector.Unboxed as V -import qualified Graphics.UI.GLFW as GLFW -import Graphics.Rendering.OpenGL.GL.CoordTrans -import Graphics.Rendering.OpenGL.GL.StateVar - -data Key - = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H - | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P - | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X - | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5 - | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3 - | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 - | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN - | KEY_LEFT | KEY_RIGHT - deriving (Enum, Bounded) - -type Keyboard = Key -> Bool - -data MouseButton = LMB | RMB | MMB - deriving (Enum, Bounded) - -data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta - deriving Enum - -data Mouse = Mouse - { button :: MouseButton -> Bool - , property :: MouseProp -> Float - } - -data Input = Input - { keyboard :: Keyboard - , mouse :: Mouse - } - --- | Return a new dummy keyboard. --- --- This function should be called to get an initial keyboard. --- --- The returned keyboard has all of its keys unpressed. --- --- For further keyboard updates, see 'getKeyboard'. -newKeyboard :: Keyboard -newKeyboard = const False - --- | Get the keyboard. -getKeyboard :: IO Keyboard -getKeyboard = - let keyboard' :: V.Vector Bool -> Keyboard - keyboard' keystate key = keystate V.! fromEnum key - keys = fmap toEnum [0..fromEnum (maxBound :: Key)] - in - (fmap (V.fromList . fmap ((==) GLFW.Press)) . mapM GLFW.getKey . fmap toGLFWkey $ keys) - >>= return . keyboard' - --- | Return a new dummy mouse. --- --- This function should be called to get an initial mouse. --- --- The returned mouse has all keys unpressed, position set to (0,0) and 0 deta values. --- --- For further mouse updates, see 'getMouse'. -newMouse :: Mouse -newMouse = Mouse (const False) (const 0) - --- | Get the mouse. --- --- The previous mouse state is required to compute position deltas. -getMouse :: Mouse -> IO Mouse -getMouse oldMouse = - let getButton :: V.Vector Bool -> MouseButton -> Bool - getButton mousestate button = mousestate V.! fromEnum button - - getProp :: V.Vector Float -> MouseProp -> Float - getProp props prop = props V.! fromEnum prop - - props xpos ypos wheel = V.fromList - [ xpos - , ypos - , xpos - property oldMouse MouseX - , ypos - property oldMouse MouseY - , wheel - , wheel - property oldMouse Wheel - ] - - getButtonState = - fmap (V.fromList . fmap ((==) GLFW.Press)) . - mapM GLFW.getMouseButton . - fmap toGLFWbutton $ buttons - - buttons = fmap toEnum [0..fromEnum (maxBound :: MouseButton)] - in do - Position xpos ypos <- get GLFW.mousePos - wheel <- get GLFW.mouseWheel - buttonState <- getButtonState - return $ Mouse - { button = getButton buttonState - , property = getProp $ props (fromIntegral xpos) (fromIntegral ypos) (fromIntegral wheel) - } - --- | Return a new dummy input. -newInput :: Input -newInput = Input newKeyboard newMouse - --- | Get input devices. -getInput :: Input -> IO Input -getInput (Input _ oldMouse) = do - keyboard <- getKeyboard - mouse <- getMouse oldMouse - return $ Input keyboard mouse - --- | Poll input devices. -pollInput :: IO () -pollInput = GLFW.pollEvents - --- | Return a mouse that reacts to button toggles. -toggledMouse :: Mouse -- ^ Previous mouse state. - -> Mouse -- ^ Current mouse state. - -> Mouse -- ^ Toggled mouse. - -toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) } - --- | Return a keyboard that reacts to key toggles. -toggledKeyboard :: Keyboard -- ^ Previous keyboard state. - -> Keyboard -- ^ Current keyboard state. - -> Keyboard -- ^ Toggled keyboard. - -toggledKeyboard prev cur key = cur key && not (prev key) - --- | Delay configuration for each mouse button. -type ButtonDelay = MouseButton -> Float - - --- | Accumulated delays for each mouse button. -data DelayedMouse = DelayedMouse - { delayedMouse :: Mouse - , delay :: ButtonDelay - , accum :: V.Vector Float - } - -newDM :: ButtonDelay -- ^ Delay configuration for each button. - -> DelayedMouse -newDM delay = DelayedMouse newMouse delay $ - V.replicate (fromEnum (maxBound :: MouseButton)) 0 - -updateDM :: DelayedMouse -- ^ Current mouse state. - -> Float -- ^ Time elapsed since last udpate. - -> DelayedMouse - -updateDM (DelayedMouse mouse delay accum) dt = - let - time b = dt + accum' V.! fromEnum b - active b = time b >= delay b - button' b = active b && button mouse b - accum' = accum V.// fmap newDelay [0 .. fromEnum (maxBound :: MouseButton)] - newDelay x = let b = toEnum x - in (x, if button' b then 0 else time b) - in - DelayedMouse mouse { button = button' } delay accum' - --- | Set the mouse position. -setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse -setMousePosition (x,y) mouse = do - GLFW.mousePos $= Position (fromIntegral x) (fromIntegral y) - getMouse mouse - --- | Set the mouse wheel. -setMouseWheel :: Integral a => a -> Mouse -> IO Mouse -setMouseWheel w mouse = do - GLFW.mouseWheel $= (fromIntegral w) - getMouse mouse - -toGLFWkey :: Key -> Int -toGLFWkey KEY_A = ord 'A' -toGLFWkey KEY_B = ord 'B' -toGLFWkey KEY_C = ord 'C' -toGLFWkey KEY_D = ord 'D' -toGLFWkey KEY_E = ord 'E' -toGLFWkey KEY_F = ord 'F' -toGLFWkey KEY_G = ord 'G' -toGLFWkey KEY_H = ord 'H' -toGLFWkey KEY_I = ord 'I' -toGLFWkey KEY_J = ord 'J' -toGLFWkey KEY_K = ord 'K' -toGLFWkey KEY_L = ord 'L' -toGLFWkey KEY_M = ord 'M' -toGLFWkey KEY_N = ord 'N' -toGLFWkey KEY_O = ord 'O' -toGLFWkey KEY_P = ord 'P' -toGLFWkey KEY_Q = ord 'Q' -toGLFWkey KEY_R = ord 'R' -toGLFWkey KEY_S = ord 'S' -toGLFWkey KEY_T = ord 'T' -toGLFWkey KEY_U = ord 'U' -toGLFWkey KEY_V = ord 'V' -toGLFWkey KEY_W = ord 'W' -toGLFWkey KEY_X = ord 'X' -toGLFWkey KEY_Y = ord 'Y' -toGLFWkey KEY_Z = ord 'Z' -toGLFWkey KEY_0 = ord '0' -toGLFWkey KEY_1 = ord '1' -toGLFWkey KEY_2 = ord '2' -toGLFWkey KEY_3 = ord '3' -toGLFWkey KEY_4 = ord '4' -toGLFWkey KEY_5 = ord '5' -toGLFWkey KEY_6 = ord '6' -toGLFWkey KEY_7 = ord '7' -toGLFWkey KEY_8 = ord '8' -toGLFWkey KEY_9 = ord '9' -toGLFWkey KEY_F1 = fromEnum GLFW.F1 -toGLFWkey KEY_F2 = fromEnum GLFW.F2 -toGLFWkey KEY_F3 = fromEnum GLFW.F3 -toGLFWkey KEY_F4 = fromEnum GLFW.F4 -toGLFWkey KEY_F5 = fromEnum GLFW.F5 -toGLFWkey KEY_F6 = fromEnum GLFW.F6 -toGLFWkey KEY_F7 = fromEnum GLFW.F7 -toGLFWkey KEY_F8 = fromEnum GLFW.F8 -toGLFWkey KEY_F9 = fromEnum GLFW.F9 -toGLFWkey KEY_F10 = fromEnum GLFW.F10 -toGLFWkey KEY_F11 = fromEnum GLFW.F11 -toGLFWkey KEY_F12 = fromEnum GLFW.F12 -toGLFWkey KEY_ESC = fromEnum GLFW.ESC -toGLFWkey KEY_SPACE = ord ' ' -toGLFWkey KEY_UP = fromEnum GLFW.UP -toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN -toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT -toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT - - -toGLFWbutton :: MouseButton -> GLFW.MouseButton -toGLFWbutton LMB = GLFW.ButtonLeft -toGLFWbutton RMB = GLFW.ButtonRight -toGLFWbutton MMB = GLFW.ButtonMiddle +module Spear.App.Input +( + -- * Data types + Key(..) +, MouseButton(..) +, MouseProp(..) +, Keyboard +, Mouse(..) +, Input(..) +, ButtonDelay +, DelayedMouse + -- * Input state querying +, newKeyboard +, getKeyboard +, newMouse +, getMouse +, newInput +, getInput +, pollInput + -- * Toggled input +, toggledMouse +, toggledKeyboard + -- * Delayed input +, newDM +, updateDM +, delayedMouse + -- * Input modifiers +, setMousePosition +, setMouseWheel +) +where + +import Data.Char (ord) +import qualified Data.Vector.Unboxed as V +import qualified Graphics.UI.GLFW as GLFW +import Graphics.Rendering.OpenGL.GL.CoordTrans +import Graphics.Rendering.OpenGL.GL.StateVar + +data Key + = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H + | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P + | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X + | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5 + | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3 + | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 + | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN + | KEY_LEFT | KEY_RIGHT + deriving (Enum, Bounded) + +type Keyboard = Key -> Bool + +data MouseButton = LMB | RMB | MMB + deriving (Enum, Bounded) + +data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta + deriving Enum + +data Mouse = Mouse + { button :: MouseButton -> Bool + , property :: MouseProp -> Float + } + +data Input = Input + { keyboard :: Keyboard + , mouse :: Mouse + } + +-- | Return a new dummy keyboard. +-- +-- This function should be called to get an initial keyboard. +-- +-- The returned keyboard has all of its keys unpressed. +-- +-- For further keyboard updates, see 'getKeyboard'. +newKeyboard :: Keyboard +newKeyboard = const False + +-- | Get the keyboard. +getKeyboard :: IO Keyboard +getKeyboard = + let keyboard' :: V.Vector Bool -> Keyboard + keyboard' keystate key = keystate V.! fromEnum key + keys = fmap toEnum [0..fromEnum (maxBound :: Key)] + in + (fmap (V.fromList . fmap ((==) GLFW.Press)) . mapM GLFW.getKey . fmap toGLFWkey $ keys) + >>= return . keyboard' + +-- | Return a new dummy mouse. +-- +-- This function should be called to get an initial mouse. +-- +-- The returned mouse has all keys unpressed, position set to (0,0) and 0 deta values. +-- +-- For further mouse updates, see 'getMouse'. +newMouse :: Mouse +newMouse = Mouse (const False) (const 0) + +-- | Get the mouse. +-- +-- The previous mouse state is required to compute position deltas. +getMouse :: Mouse -> IO Mouse +getMouse oldMouse = + let getButton :: V.Vector Bool -> MouseButton -> Bool + getButton mousestate button = mousestate V.! fromEnum button + + getProp :: V.Vector Float -> MouseProp -> Float + getProp props prop = props V.! fromEnum prop + + props xpos ypos wheel = V.fromList + [ xpos + , ypos + , xpos - property oldMouse MouseX + , ypos - property oldMouse MouseY + , wheel + , wheel - property oldMouse Wheel + ] + + getButtonState = + fmap (V.fromList . fmap ((==) GLFW.Press)) . + mapM GLFW.getMouseButton . + fmap toGLFWbutton $ buttons + + buttons = fmap toEnum [0..fromEnum (maxBound :: MouseButton)] + in do + Position xpos ypos <- get GLFW.mousePos + wheel <- get GLFW.mouseWheel + buttonState <- getButtonState + return $ Mouse + { button = getButton buttonState + , property = getProp $ props (fromIntegral xpos) (fromIntegral ypos) (fromIntegral wheel) + } + +-- | Return a new dummy input. +newInput :: Input +newInput = Input newKeyboard newMouse + +-- | Get input devices. +getInput :: Input -> IO Input +getInput (Input _ oldMouse) = do + keyboard <- getKeyboard + mouse <- getMouse oldMouse + return $ Input keyboard mouse + +-- | Poll input devices. +pollInput :: IO () +pollInput = GLFW.pollEvents + +-- | Return a mouse that reacts to button toggles. +toggledMouse :: Mouse -- ^ Previous mouse state. + -> Mouse -- ^ Current mouse state. + -> Mouse -- ^ Toggled mouse. + +toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) } + +-- | Return a keyboard that reacts to key toggles. +toggledKeyboard :: Keyboard -- ^ Previous keyboard state. + -> Keyboard -- ^ Current keyboard state. + -> Keyboard -- ^ Toggled keyboard. + +toggledKeyboard prev cur key = cur key && not (prev key) + +-- | Delay configuration for each mouse button. +type ButtonDelay = MouseButton -> Float + + +-- | Accumulated delays for each mouse button. +data DelayedMouse = DelayedMouse + { delayedMouse :: Mouse + , delay :: ButtonDelay + , accum :: V.Vector Float + } + +newDM :: ButtonDelay -- ^ Delay configuration for each button. + -> DelayedMouse +newDM delay = DelayedMouse newMouse delay $ + V.replicate (fromEnum (maxBound :: MouseButton)) 0 + +updateDM :: DelayedMouse -- ^ Current mouse state. + -> Float -- ^ Time elapsed since last udpate. + -> DelayedMouse + +updateDM (DelayedMouse mouse delay accum) dt = + let + time b = dt + accum' V.! fromEnum b + active b = time b >= delay b + button' b = active b && button mouse b + accum' = accum V.// fmap newDelay [0 .. fromEnum (maxBound :: MouseButton)] + newDelay x = let b = toEnum x + in (x, if button' b then 0 else time b) + in + DelayedMouse mouse { button = button' } delay accum' + +-- | Set the mouse position. +setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse +setMousePosition (x,y) mouse = do + GLFW.mousePos $= Position (fromIntegral x) (fromIntegral y) + getMouse mouse + +-- | Set the mouse wheel. +setMouseWheel :: Integral a => a -> Mouse -> IO Mouse +setMouseWheel w mouse = do + GLFW.mouseWheel $= (fromIntegral w) + getMouse mouse + +toGLFWkey :: Key -> Int +toGLFWkey KEY_A = ord 'A' +toGLFWkey KEY_B = ord 'B' +toGLFWkey KEY_C = ord 'C' +toGLFWkey KEY_D = ord 'D' +toGLFWkey KEY_E = ord 'E' +toGLFWkey KEY_F = ord 'F' +toGLFWkey KEY_G = ord 'G' +toGLFWkey KEY_H = ord 'H' +toGLFWkey KEY_I = ord 'I' +toGLFWkey KEY_J = ord 'J' +toGLFWkey KEY_K = ord 'K' +toGLFWkey KEY_L = ord 'L' +toGLFWkey KEY_M = ord 'M' +toGLFWkey KEY_N = ord 'N' +toGLFWkey KEY_O = ord 'O' +toGLFWkey KEY_P = ord 'P' +toGLFWkey KEY_Q = ord 'Q' +toGLFWkey KEY_R = ord 'R' +toGLFWkey KEY_S = ord 'S' +toGLFWkey KEY_T = ord 'T' +toGLFWkey KEY_U = ord 'U' +toGLFWkey KEY_V = ord 'V' +toGLFWkey KEY_W = ord 'W' +toGLFWkey KEY_X = ord 'X' +toGLFWkey KEY_Y = ord 'Y' +toGLFWkey KEY_Z = ord 'Z' +toGLFWkey KEY_0 = ord '0' +toGLFWkey KEY_1 = ord '1' +toGLFWkey KEY_2 = ord '2' +toGLFWkey KEY_3 = ord '3' +toGLFWkey KEY_4 = ord '4' +toGLFWkey KEY_5 = ord '5' +toGLFWkey KEY_6 = ord '6' +toGLFWkey KEY_7 = ord '7' +toGLFWkey KEY_8 = ord '8' +toGLFWkey KEY_9 = ord '9' +toGLFWkey KEY_F1 = fromEnum GLFW.F1 +toGLFWkey KEY_F2 = fromEnum GLFW.F2 +toGLFWkey KEY_F3 = fromEnum GLFW.F3 +toGLFWkey KEY_F4 = fromEnum GLFW.F4 +toGLFWkey KEY_F5 = fromEnum GLFW.F5 +toGLFWkey KEY_F6 = fromEnum GLFW.F6 +toGLFWkey KEY_F7 = fromEnum GLFW.F7 +toGLFWkey KEY_F8 = fromEnum GLFW.F8 +toGLFWkey KEY_F9 = fromEnum GLFW.F9 +toGLFWkey KEY_F10 = fromEnum GLFW.F10 +toGLFWkey KEY_F11 = fromEnum GLFW.F11 +toGLFWkey KEY_F12 = fromEnum GLFW.F12 +toGLFWkey KEY_ESC = fromEnum GLFW.ESC +toGLFWkey KEY_SPACE = ord ' ' +toGLFWkey KEY_UP = fromEnum GLFW.UP +toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN +toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT +toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT + + +toGLFWbutton :: MouseButton -> GLFW.MouseButton +toGLFWbutton LMB = GLFW.ButtonLeft +toGLFWbutton RMB = GLFW.ButtonRight +toGLFWbutton MMB = GLFW.ButtonMiddle diff --git a/Spear/Assets/Image.hsc b/Spear/Assets/Image.hsc index 0efbca6..f9fc025 100644 --- a/Spear/Assets/Image.hsc +++ b/Spear/Assets/Image.hsc @@ -1,126 +1,126 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - -module Spear.Assets.Image -( - -- * Data types - Image - -- * Loading and unloading -, loadImage - -- * Accessors -, width -, height -, bpp -, pixels -) -where - -import Spear.Game -import Foreign.Ptr -import Foreign.Storable -import Foreign.C.Types -import Foreign.C.String -import Foreign.Marshal.Utils as Foreign (with) -import Foreign.Marshal.Alloc (alloca) -import Data.List (splitAt, elemIndex) -import Data.Char (toLower) - -#include "Image.h" -#include "BMP/BMP_load.h" - -data ImageErrorCode - = ImageSuccess - | ImageReadError - | ImageMemoryAllocationError - | ImageFileNotFound - | ImageInvalidFormat - | ImageNoSuitableLoader - deriving (Eq, Enum, Show) - -data CImage = CImage - { cwidth :: CInt - , cheight :: CInt - , cbpp :: CInt - , cpixels :: Ptr CUChar - } - -instance Storable CImage where - sizeOf _ = #{size Image} - alignment _ = alignment (undefined :: CInt) - - peek ptr = do - width <- #{peek Image, width} ptr - height <- #{peek Image, height} ptr - bpp <- #{peek Image, bpp} ptr - pixels <- #{peek Image, pixels} ptr - return $ CImage width height bpp pixels - - poke ptr (CImage width height bpp pixels) = do - #{poke Image, width} ptr width - #{poke Image, height} ptr height - #{poke Image, bpp} ptr bpp - #{poke Image, pixels} ptr pixels - --- | Represents an image 'Resource'. -data Image = Image - { imageData :: CImage - , rkey :: Resource - } - -instance ResourceClass Image where - getResource = rkey - -foreign import ccall "Image.h image_free" - image_free :: Ptr CImage -> IO () - -foreign import ccall "BMP_load.h BMP_load" - bmp_load' :: Ptr CChar -> Ptr CImage -> IO Int - -bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode -bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code - --- | Load the image specified by the given file. -loadImage :: FilePath -> Game s Image -loadImage file = do - dotPos <- case elemIndex '.' file of - Nothing -> gameError $ "file name has no extension: " ++ file - Just p -> return p - - let ext = map toLower . tail . snd $ splitAt dotPos file - - result <- gameIO . alloca $ \ptr -> do - status <- withCString file $ \fileCstr -> do - case ext of - "bmp" -> bmp_load fileCstr ptr - _ -> return ImageNoSuitableLoader - - case status of - ImageSuccess -> peek ptr >>= return . Right - ImageReadError -> return . Left $ "read error" - ImageMemoryAllocationError -> return . Left $ "memory allocation error" - ImageFileNotFound -> return . Left $ "file not found" - ImageInvalidFormat -> return . Left $ "invalid format" - ImageNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext - - case result of - Right image -> register (freeImage image) >>= return . Image image - Left err -> gameError $ "loadImage: " ++ err - --- | Free the given 'CImage'. -freeImage :: CImage -> IO () -freeImage image = Foreign.with image image_free - --- | Return the given image's width. -width :: Image -> Int -width = fromIntegral . cwidth . imageData - --- | Return the given image's height. -height :: Image -> Int -height = fromIntegral . cheight . imageData - --- | Return the given image's bits per pixel. -bpp :: Image -> Int -bpp = fromIntegral . cbpp . imageData - --- | Return the given image's pixels. -pixels :: Image -> Ptr CUChar -pixels = cpixels . imageData +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Spear.Assets.Image +( + -- * Data types + Image + -- * Loading and unloading +, loadImage + -- * Accessors +, width +, height +, bpp +, pixels +) +where + +import Spear.Game +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Foreign.Marshal.Utils as Foreign (with) +import Foreign.Marshal.Alloc (alloca) +import Data.List (splitAt, elemIndex) +import Data.Char (toLower) + +#include "Image.h" +#include "BMP/BMP_load.h" + +data ImageErrorCode + = ImageSuccess + | ImageReadError + | ImageMemoryAllocationError + | ImageFileNotFound + | ImageInvalidFormat + | ImageNoSuitableLoader + deriving (Eq, Enum, Show) + +data CImage = CImage + { cwidth :: CInt + , cheight :: CInt + , cbpp :: CInt + , cpixels :: Ptr CUChar + } + +instance Storable CImage where + sizeOf _ = #{size Image} + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + width <- #{peek Image, width} ptr + height <- #{peek Image, height} ptr + bpp <- #{peek Image, bpp} ptr + pixels <- #{peek Image, pixels} ptr + return $ CImage width height bpp pixels + + poke ptr (CImage width height bpp pixels) = do + #{poke Image, width} ptr width + #{poke Image, height} ptr height + #{poke Image, bpp} ptr bpp + #{poke Image, pixels} ptr pixels + +-- | Represents an image 'Resource'. +data Image = Image + { imageData :: CImage + , rkey :: Resource + } + +instance ResourceClass Image where + getResource = rkey + +foreign import ccall "Image.h image_free" + image_free :: Ptr CImage -> IO () + +foreign import ccall "BMP_load.h BMP_load" + bmp_load' :: Ptr CChar -> Ptr CImage -> IO Int + +bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode +bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code + +-- | Load the image specified by the given file. +loadImage :: FilePath -> Game s Image +loadImage file = do + dotPos <- case elemIndex '.' file of + Nothing -> gameError $ "file name has no extension: " ++ file + Just p -> return p + + let ext = map toLower . tail . snd $ splitAt dotPos file + + result <- gameIO . alloca $ \ptr -> do + status <- withCString file $ \fileCstr -> do + case ext of + "bmp" -> bmp_load fileCstr ptr + _ -> return ImageNoSuitableLoader + + case status of + ImageSuccess -> peek ptr >>= return . Right + ImageReadError -> return . Left $ "read error" + ImageMemoryAllocationError -> return . Left $ "memory allocation error" + ImageFileNotFound -> return . Left $ "file not found" + ImageInvalidFormat -> return . Left $ "invalid format" + ImageNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext + + case result of + Right image -> register (freeImage image) >>= return . Image image + Left err -> gameError $ "loadImage: " ++ err + +-- | Free the given 'CImage'. +freeImage :: CImage -> IO () +freeImage image = Foreign.with image image_free + +-- | Return the given image's width. +width :: Image -> Int +width = fromIntegral . cwidth . imageData + +-- | Return the given image's height. +height :: Image -> Int +height = fromIntegral . cheight . imageData + +-- | Return the given image's bits per pixel. +bpp :: Image -> Int +bpp = fromIntegral . cbpp . imageData + +-- | Return the given image's pixels. +pixels :: Image -> Ptr CUChar +pixels = cpixels . imageData diff --git a/Spear/Assets/Image/Image.c b/Spear/Assets/Image/Image.c index 9abebe2..f4150e1 100644 --- a/Spear/Assets/Image/Image.c +++ b/Spear/Assets/Image/Image.c @@ -1,8 +1,8 @@ -#include "Image.h" -#include - - -void image_free (Image* image) -{ - free (image->pixels); -} +#include "Image.h" +#include + + +void image_free (Image* image) +{ + free (image->pixels); +} 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 @@ -#ifndef _SPEAR_IMAGE_H -#define _SPEAR_IMAGE_H - -#include "sys_types.h" - - -typedef struct -{ - int width; - int height; - int bpp; // Bits per pixel. - // If bpp = 3 then format = RGB. - // If bpp = 4 then format = RGBA. - U8* pixels; -} -Image; - - -#ifdef __cplusplus -extern "C" { -#endif - -/// Frees the given Image from memory. -/// The 'image' pointer itself is not freed. -void image_free (Image* image); - -#ifdef __cplusplus -} -#endif - - -#endif // _SPEAR_IMAGE_H +#ifndef _SPEAR_IMAGE_H +#define _SPEAR_IMAGE_H + +#include "sys_types.h" + + +typedef struct +{ + int width; + int height; + int bpp; // Bits per pixel. + // If bpp = 3 then format = RGB. + // If bpp = 4 then format = RGBA. + U8* pixels; +} +Image; + + +#ifdef __cplusplus +extern "C" { +#endif + +/// Frees the given Image from memory. +/// The 'image' pointer itself is not freed. +void image_free (Image* image); + +#ifdef __cplusplus +} +#endif + + +#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 @@ -#ifndef _SPEAR_IMAGE_ERROR_CODE_H -#define _SPEAR_IMAGE_ERROR_CODE_H - -typedef enum -{ - Image_Success, - Image_Read_Error, - Image_Memory_Allocation_Error, - Image_File_Not_Found, - Image_Invalid_Format, - Image_No_Suitable_Loader, -} -Image_error_code; - -#endif // _SPEAR_IMAGE_ERROR_CODE_H +#ifndef _SPEAR_IMAGE_ERROR_CODE_H +#define _SPEAR_IMAGE_ERROR_CODE_H + +typedef enum +{ + Image_Success, + Image_Read_Error, + Image_Memory_Allocation_Error, + Image_File_Not_Found, + Image_Invalid_Format, + Image_No_Suitable_Loader, +} +Image_error_code; + +#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 @@ -#ifndef _SPEAR_SYS_TYPES_H -#define _SPEAR_SYS_TYPES_H - -#include - -typedef int8_t I8; -typedef int16_t I16; -typedef int32_t I32; -typedef int64_t I64; -typedef uint8_t U8; -typedef uint16_t U16; -typedef uint32_t U32; -typedef uint64_t U64; - -#endif // _SPEAR_SYS_TYPES_H - +#ifndef _SPEAR_SYS_TYPES_H +#define _SPEAR_SYS_TYPES_H + +#include + +typedef int8_t I8; +typedef int16_t I16; +typedef int32_t I32; +typedef int64_t I64; +typedef uint8_t U8; +typedef uint16_t U16; +typedef uint32_t U32; +typedef uint64_t U64; + +#endif // _SPEAR_SYS_TYPES_H + 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 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - -module Spear.Assets.Model -( - -- * Data types - Vec2(..) -, Vec3(..) -, TexCoord(..) -, CTriangle(..) -, Box(..) -, Skin(..) -, Animation(..) -, Triangle(..) -, Model(..) - -- * Loading -, loadModel - -- * Accessors -, animated -, animation -, animationByName -, triangles' - -- * Manipulation -, transformVerts -, transformNormals -, toGround -, modelBoxes -) -where - -import Spear.Game - -import qualified Data.ByteString.Char8 as B -import Data.Char (toLower) -import Data.List (splitAt, elemIndex) -import qualified Data.Vector as V -import qualified Data.Vector.Storable as S -import Foreign.Ptr -import Foreign.Storable -import Foreign.C.Types -import Foreign.C.String -import Foreign.Marshal.Utils as Foreign (with) -import Foreign.Marshal.Alloc (alloca, allocaBytes) -import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) -import Unsafe.Coerce (unsafeCoerce) - -#include "Model.h" -#include "MD2/MD2_load.h" -#include "OBJ/OBJ_load.h" - -data ModelErrorCode - = ModelSuccess - | ModelReadError - | ModelMemoryAllocationError - | ModelFileNotFound - | ModelFileMismatch - | ModelNoSuitableLoader - deriving (Eq, Enum, Show) - -sizeFloat = #{size float} -sizePtr = #{size int*} - --- | A 2D vector. -data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float - -instance Storable Vec2 where - sizeOf _ = 2*sizeFloat - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - f0 <- peekByteOff ptr 0 - f1 <- peekByteOff ptr sizeFloat - return $ Vec2 f0 f1 - - poke ptr (Vec2 f0 f1) = do - pokeByteOff ptr 0 f0 - pokeByteOff ptr sizeFloat f1 - --- | A 3D vector. -data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float - -instance Storable Vec3 where - sizeOf _ = 3*sizeFloat - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - f0 <- peekByteOff ptr 0 - f1 <- peekByteOff ptr sizeFloat - f2 <- peekByteOff ptr (2*sizeFloat) - return $ Vec3 f0 f1 f2 - - poke ptr (Vec3 f0 f1 f2) = do - pokeByteOff ptr 0 f0 - pokeByteOff ptr sizeFloat f1 - pokeByteOff ptr (2*sizeFloat) f2 - --- | A 2D texture coordinate. -data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float - -instance Storable TexCoord where - sizeOf _ = 2*sizeFloat - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - f0 <- peekByteOff ptr 0 - f1 <- peekByteOff ptr sizeFloat - return $ TexCoord f0 f1 - - poke ptr (TexCoord f0 f1) = do - pokeByteOff ptr 0 f0 - pokeByteOff ptr sizeFloat f1 - --- | A raw triangle holding vertex/normal and texture indices. -data CTriangle = CTriangle - { vertexIndex0 :: {-# UNPACK #-} !CUShort - , vertexIndex1 :: {-# UNPACK #-} !CUShort - , vertexIndex2 :: {-# UNPACK #-} !CUShort - , textureIndex1 :: {-# UNPACK #-} !CUShort - , textureIndex2 :: {-# UNPACK #-} !CUShort - , textureIndex3 :: {-# UNPACK #-} !CUShort - } - -instance Storable CTriangle where - sizeOf _ = #{size triangle} - alignment _ = alignment (undefined :: CUShort) - - peek ptr = do - v0 <- #{peek triangle, vertexIndices[0]} ptr - v1 <- #{peek triangle, vertexIndices[1]} ptr - v2 <- #{peek triangle, vertexIndices[2]} ptr - - t0 <- #{peek triangle, textureIndices[0]} ptr - t1 <- #{peek triangle, textureIndices[1]} ptr - t2 <- #{peek triangle, textureIndices[2]} ptr - - return $ CTriangle v0 v1 v2 t0 t1 t2 - - poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do - #{poke triangle, vertexIndices[0]} ptr v0 - #{poke triangle, vertexIndices[1]} ptr v1 - #{poke triangle, vertexIndices[2]} ptr v2 - - #{poke triangle, textureIndices[0]} ptr t0 - #{poke triangle, textureIndices[1]} ptr t1 - #{poke triangle, textureIndices[2]} ptr t2 - --- | A 3D axis-aligned bounding box. -data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 - -instance Storable Box where - sizeOf _ = 6 * sizeFloat - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - xmin <- peekByteOff ptr 0 - ymin <- peekByteOff ptr sizeFloat - zmin <- peekByteOff ptr $ 2*sizeFloat - xmax <- peekByteOff ptr $ 3*sizeFloat - ymax <- peekByteOff ptr $ 4*sizeFloat - zmax <- peekByteOff ptr $ 5*sizeFloat - return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax) - - poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do - pokeByteOff ptr 0 xmin - pokeByteOff ptr sizeFloat ymin - pokeByteOff ptr (2*sizeFloat) zmin - pokeByteOff ptr (3*sizeFloat) xmax - pokeByteOff ptr (4*sizeFloat) ymax - pokeByteOff ptr (5*sizeFloat) zmax - --- | A model skin. -newtype Skin = Skin { skinName :: B.ByteString } - -instance Storable Skin where - sizeOf (Skin s) = 64 - alignment _ = 1 - - peek ptr = do - s <- B.packCString $ unsafeCoerce ptr - return $ Skin s - - poke ptr (Skin s) = do - B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len - --- | A model animation. --- --- See also: 'animation', 'animationByName', 'numAnimations'. -data Animation = Animation - { name :: B.ByteString - , start :: Int - , end :: Int - } - -instance Storable Animation where - sizeOf _ = #{size animation} - alignment _ = alignment (undefined :: CUInt) - - peek ptr = do - name <- B.packCString (unsafeCoerce ptr) - start <- #{peek animation, start} ptr - end <- #{peek animation, end} ptr - return $ Animation name start end - - poke ptr (Animation name start end) = do - B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len - #{poke animation, start} ptr start - #{poke animation, end} ptr end - --- | A 3D model. -data Model = Model - { vertices :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' vertices. - , normals :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' normals. - , texCoords :: S.Vector TexCoord -- ^ Array of 'numTexCoords' texture coordinates. - , triangles :: S.Vector CTriangle -- ^ Array of 'numTriangles' triangles. - , skins :: S.Vector Skin -- ^ Array of 'numSkins' skins. - , animations :: S.Vector Animation -- ^ Array of 'numAnimations' animations. - , numFrames :: Int -- ^ Number of frames. - , numVerts :: Int -- ^ Number of vertices (and normals) per frame. - , numTriangles :: Int -- ^ Number of triangles in one frame. - , numTexCoords :: Int -- ^ Number of texture coordinates in one frame. - , numSkins :: Int -- ^ Number of skins. - , numAnimations :: Int -- ^ Number of animations. - } - -instance Storable Model where - sizeOf _ = #{size Model} - alignment _ = alignment (undefined :: CUInt) - - peek ptr = do - numFrames <- #{peek Model, numFrames} ptr - numVertices <- #{peek Model, numVertices} ptr - numTriangles <- #{peek Model, numTriangles} ptr - numTexCoords <- #{peek Model, numTexCoords} ptr - numSkins <- #{peek Model, numSkins} ptr - numAnimations <- #{peek Model, numAnimations} ptr - pVerts <- peek (unsafeCoerce ptr) - pNormals <- peekByteOff ptr sizePtr - pTexCoords <- peekByteOff ptr (2*sizePtr) - pTriangles <- peekByteOff ptr (3*sizePtr) - pSkins <- peekByteOff ptr (4*sizePtr) - pAnimations <- peekByteOff ptr (5*sizePtr) - vertices <- fmap S.fromList $ peekArray (numVertices*numFrames) pVerts - normals <- fmap S.fromList $ peekArray (numVertices*numFrames) pNormals - texCoords <- fmap S.fromList $ peekArray numTexCoords pTexCoords - triangles <- fmap S.fromList $ peekArray numTriangles pTriangles - skins <- fmap S.fromList $ peekArray numSkins pSkins - animations <- fmap S.fromList $ peekArray numAnimations pAnimations - return $ - Model vertices normals texCoords triangles skins animations - numFrames numVertices numTriangles numTexCoords numSkins numAnimations - - poke ptr - (Model verts normals texCoords tris skins animations - numFrames numVerts numTris numTex numSkins numAnimations) = - S.unsafeWith verts $ \pVerts -> - S.unsafeWith normals $ \pNormals -> - S.unsafeWith texCoords $ \pTexCoords -> - S.unsafeWith tris $ \pTris -> - S.unsafeWith skins $ \pSkins -> - S.unsafeWith animations $ \pAnimations -> do - #{poke Model, vertices} ptr pVerts - #{poke Model, normals} ptr pNormals - #{poke Model, texCoords} ptr pTexCoords - #{poke Model, triangles} ptr pTris - #{poke Model, skins} ptr pSkins - #{poke Model, animations} ptr pAnimations - #{poke Model, numFrames} ptr numFrames - #{poke Model, numVertices} ptr numVerts - #{poke Model, numTriangles} ptr numTris - #{poke Model, numTexCoords} ptr numTex - #{poke Model, numSkins} ptr numSkins - #{poke Model, numAnimations} ptr numAnimations - --- | A model triangle. --- --- See also: 'triangles''. -data Triangle = Triangle - { v0 :: Vec3 - , v1 :: Vec3 - , v2 :: Vec3 - , n0 :: Vec3 - , n1 :: Vec3 - , n2 :: Vec3 - , t0 :: TexCoord - , t1 :: TexCoord - , t2 :: TexCoord - } - -instance Storable Triangle where - sizeOf _ = #{size model_triangle} - alignment _ = alignment (undefined :: Float) - - peek ptr = do - v0 <- #{peek model_triangle, v0} ptr - v1 <- #{peek model_triangle, v1} ptr - v2 <- #{peek model_triangle, v2} ptr - n0 <- #{peek model_triangle, n0} ptr - n1 <- #{peek model_triangle, n1} ptr - n2 <- #{peek model_triangle, n2} ptr - t0 <- #{peek model_triangle, t0} ptr - t1 <- #{peek model_triangle, t1} ptr - t2 <- #{peek model_triangle, t2} ptr - return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2 - - poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do - #{poke model_triangle, v0} ptr v0 - #{poke model_triangle, v1} ptr v1 - #{poke model_triangle, v2} ptr v2 - #{poke model_triangle, n0} ptr n0 - #{poke model_triangle, n1} ptr n1 - #{poke model_triangle, n2} ptr n2 - #{poke model_triangle, t0} ptr t0 - #{poke model_triangle, t1} ptr t1 - #{poke model_triangle, t2} ptr t2 - -foreign import ccall "Model.h model_free" - model_free :: Ptr Model -> IO () - -foreign import ccall "MD2_load.h MD2_load" - md2_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int - -foreign import ccall "OBJ_load.h OBJ_load" - obj_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int - -md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode -md2_load file clockwise leftHanded model = - md2_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code - -obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode -obj_load file clockwise leftHanded model = - obj_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code - --- | Load the model specified by the given file. -loadModel :: FilePath -> Game s Model -loadModel file = do - dotPos <- case elemIndex '.' file of - Nothing -> gameError $ "file name has no extension: " ++ file - Just p -> return p - - let ext = map toLower . tail . snd $ splitAt dotPos file - - result <- gameIO . alloca $ \ptr -> do - status <- withCString file $ \fileCstr -> do - case ext of - "md2" -> md2_load fileCstr 0 0 ptr - "obj" -> obj_load fileCstr 0 0 ptr - _ -> return ModelNoSuitableLoader - - case status of - ModelSuccess -> do - model <- peek ptr - model_free ptr - return . Right $ model - ModelReadError -> return . Left $ "read error" - ModelMemoryAllocationError -> return . Left $ "memory allocation error" - ModelFileNotFound -> return . Left $ "file not found" - ModelFileMismatch -> return . Left $ "file mismatch" - ModelNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext - - case result of - Right model -> return model - Left err -> gameError $ "loadModel: " ++ err - --- | Return 'True' if the model is animated, 'False' otherwise. -animated :: Model -> Bool -animated = (>1) . numFrames - --- | Return the model's ith animation. -animation :: Model -> Int -> Animation -animation model i = animations model S.! i - --- | Return the animation specified by the given string. -animationByName :: Model -> String -> Maybe Animation -animationByName model anim = - let anim' = B.pack anim in S.find ((==) anim' . name) $ animations model - --- | Return a copy of the model's triangles. -triangles' :: Model -> IO [Triangle] -triangles' model = - let n = numVerts model * numFrames model - in with model $ \modelPtr -> - allocaArray n $ \arrayPtr -> do - model_copy_triangles modelPtr arrayPtr - tris <- peekArray n arrayPtr - return tris - -foreign import ccall "Model.h model_copy_triangles" - model_copy_triangles :: Ptr Model -> Ptr Triangle -> IO () - --- | Transform the model's vertices. -transformVerts :: Model -> (Vec3 -> Vec3) -> Model -transformVerts model f = model { vertices = vertices' } - where - n = numVerts model * numFrames model - vertices' = S.generate n f' - f' i = f $ vertices model S.! i - --- | Transform the model's normals. -transformNormals :: Model -> (Vec3 -> Vec3) -> Model -transformNormals model f = model { normals = normals' } - where - n = numVerts model * numFrames model - normals' = S.generate n f' - f' i = f $ normals model S.! i - --- | Translate the model such that its lowest point has y = 0. -toGround :: Model -> IO Model -toGround model = - let model' = model { vertices = S.generate n $ \i -> vertices model S.! i } - n = numVerts model * numFrames model - in - with model' model_to_ground >> return model' - -foreign import ccall "Model.h model_to_ground" - model_to_ground :: Ptr Model -> IO () - --- | Get the model's 3D bounding boxes. -modelBoxes :: Model -> IO (V.Vector Box) -modelBoxes model = - with model $ \modelPtr -> - allocaArray (numVerts model * numFrames model * 6) $ \pointsPtr -> do - model_compute_boxes modelPtr pointsPtr - let n = numFrames model - getBoxes = peekBoxes pointsPtr n 0 0 $ return [] - peekBoxes ptr n cur off l - | cur == n = l - | otherwise = do - xmin <- peekByteOff ptr off - ymin <- peekByteOff ptr $ off + sizeFloat - zmin <- peekByteOff ptr $ off + 2*sizeFloat - xmax <- peekByteOff ptr $ off + 3*sizeFloat - ymax <- peekByteOff ptr $ off + 4*sizeFloat - zmax <- peekByteOff ptr $ off + 5*sizeFloat - let pmin = Vec3 xmin ymin zmin - pmax = Vec3 xmax ymax zmax - box = Box pmin pmax - peekBoxes ptr n (cur+1) (off + 6*sizeFloat) $ fmap (box:) l - fmap (V.fromList . reverse) getBoxes - -foreign import ccall "Model.h model_compute_boxes" - model_compute_boxes :: Ptr Model -> Ptr Vec2 -> IO () +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Spear.Assets.Model +( + -- * Data types + Vec2(..) +, Vec3(..) +, TexCoord(..) +, CTriangle(..) +, Box(..) +, Skin(..) +, Animation(..) +, Triangle(..) +, Model(..) + -- * Loading +, loadModel + -- * Accessors +, animated +, animation +, animationByName +, triangles' + -- * Manipulation +, transformVerts +, transformNormals +, toGround +, modelBoxes +) +where + +import Spear.Game + +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower) +import Data.List (splitAt, elemIndex) +import qualified Data.Vector as V +import qualified Data.Vector.Storable as S +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Foreign.Marshal.Utils as Foreign (with) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) +import Unsafe.Coerce (unsafeCoerce) + +#include "Model.h" +#include "MD2/MD2_load.h" +#include "OBJ/OBJ_load.h" + +data ModelErrorCode + = ModelSuccess + | ModelReadError + | ModelMemoryAllocationError + | ModelFileNotFound + | ModelFileMismatch + | ModelNoSuitableLoader + deriving (Eq, Enum, Show) + +sizeFloat = #{size float} +sizePtr = #{size int*} + +-- | A 2D vector. +data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float + +instance Storable Vec2 where + sizeOf _ = 2*sizeFloat + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + f0 <- peekByteOff ptr 0 + f1 <- peekByteOff ptr sizeFloat + return $ Vec2 f0 f1 + + poke ptr (Vec2 f0 f1) = do + pokeByteOff ptr 0 f0 + pokeByteOff ptr sizeFloat f1 + +-- | A 3D vector. +data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float + +instance Storable Vec3 where + sizeOf _ = 3*sizeFloat + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + f0 <- peekByteOff ptr 0 + f1 <- peekByteOff ptr sizeFloat + f2 <- peekByteOff ptr (2*sizeFloat) + return $ Vec3 f0 f1 f2 + + poke ptr (Vec3 f0 f1 f2) = do + pokeByteOff ptr 0 f0 + pokeByteOff ptr sizeFloat f1 + pokeByteOff ptr (2*sizeFloat) f2 + +-- | A 2D texture coordinate. +data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float + +instance Storable TexCoord where + sizeOf _ = 2*sizeFloat + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + f0 <- peekByteOff ptr 0 + f1 <- peekByteOff ptr sizeFloat + return $ TexCoord f0 f1 + + poke ptr (TexCoord f0 f1) = do + pokeByteOff ptr 0 f0 + pokeByteOff ptr sizeFloat f1 + +-- | A raw triangle holding vertex/normal and texture indices. +data CTriangle = CTriangle + { vertexIndex0 :: {-# UNPACK #-} !CUShort + , vertexIndex1 :: {-# UNPACK #-} !CUShort + , vertexIndex2 :: {-# UNPACK #-} !CUShort + , textureIndex1 :: {-# UNPACK #-} !CUShort + , textureIndex2 :: {-# UNPACK #-} !CUShort + , textureIndex3 :: {-# UNPACK #-} !CUShort + } + +instance Storable CTriangle where + sizeOf _ = #{size triangle} + alignment _ = alignment (undefined :: CUShort) + + peek ptr = do + v0 <- #{peek triangle, vertexIndices[0]} ptr + v1 <- #{peek triangle, vertexIndices[1]} ptr + v2 <- #{peek triangle, vertexIndices[2]} ptr + + t0 <- #{peek triangle, textureIndices[0]} ptr + t1 <- #{peek triangle, textureIndices[1]} ptr + t2 <- #{peek triangle, textureIndices[2]} ptr + + return $ CTriangle v0 v1 v2 t0 t1 t2 + + poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do + #{poke triangle, vertexIndices[0]} ptr v0 + #{poke triangle, vertexIndices[1]} ptr v1 + #{poke triangle, vertexIndices[2]} ptr v2 + + #{poke triangle, textureIndices[0]} ptr t0 + #{poke triangle, textureIndices[1]} ptr t1 + #{poke triangle, textureIndices[2]} ptr t2 + +-- | A 3D axis-aligned bounding box. +data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 + +instance Storable Box where + sizeOf _ = 6 * sizeFloat + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + xmin <- peekByteOff ptr 0 + ymin <- peekByteOff ptr sizeFloat + zmin <- peekByteOff ptr $ 2*sizeFloat + xmax <- peekByteOff ptr $ 3*sizeFloat + ymax <- peekByteOff ptr $ 4*sizeFloat + zmax <- peekByteOff ptr $ 5*sizeFloat + return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax) + + poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do + pokeByteOff ptr 0 xmin + pokeByteOff ptr sizeFloat ymin + pokeByteOff ptr (2*sizeFloat) zmin + pokeByteOff ptr (3*sizeFloat) xmax + pokeByteOff ptr (4*sizeFloat) ymax + pokeByteOff ptr (5*sizeFloat) zmax + +-- | A model skin. +newtype Skin = Skin { skinName :: B.ByteString } + +instance Storable Skin where + sizeOf (Skin s) = 64 + alignment _ = 1 + + peek ptr = do + s <- B.packCString $ unsafeCoerce ptr + return $ Skin s + + poke ptr (Skin s) = do + B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len + +-- | A model animation. +-- +-- See also: 'animation', 'animationByName', 'numAnimations'. +data Animation = Animation + { name :: B.ByteString + , start :: Int + , end :: Int + } + +instance Storable Animation where + sizeOf _ = #{size animation} + alignment _ = alignment (undefined :: CUInt) + + peek ptr = do + name <- B.packCString (unsafeCoerce ptr) + start <- #{peek animation, start} ptr + end <- #{peek animation, end} ptr + return $ Animation name start end + + poke ptr (Animation name start end) = do + B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len + #{poke animation, start} ptr start + #{poke animation, end} ptr end + +-- | A 3D model. +data Model = Model + { vertices :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' vertices. + , normals :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' normals. + , texCoords :: S.Vector TexCoord -- ^ Array of 'numTexCoords' texture coordinates. + , triangles :: S.Vector CTriangle -- ^ Array of 'numTriangles' triangles. + , skins :: S.Vector Skin -- ^ Array of 'numSkins' skins. + , animations :: S.Vector Animation -- ^ Array of 'numAnimations' animations. + , numFrames :: Int -- ^ Number of frames. + , numVerts :: Int -- ^ Number of vertices (and normals) per frame. + , numTriangles :: Int -- ^ Number of triangles in one frame. + , numTexCoords :: Int -- ^ Number of texture coordinates in one frame. + , numSkins :: Int -- ^ Number of skins. + , numAnimations :: Int -- ^ Number of animations. + } + +instance Storable Model where + sizeOf _ = #{size Model} + alignment _ = alignment (undefined :: CUInt) + + peek ptr = do + numFrames <- #{peek Model, numFrames} ptr + numVertices <- #{peek Model, numVertices} ptr + numTriangles <- #{peek Model, numTriangles} ptr + numTexCoords <- #{peek Model, numTexCoords} ptr + numSkins <- #{peek Model, numSkins} ptr + numAnimations <- #{peek Model, numAnimations} ptr + pVerts <- peek (unsafeCoerce ptr) + pNormals <- peekByteOff ptr sizePtr + pTexCoords <- peekByteOff ptr (2*sizePtr) + pTriangles <- peekByteOff ptr (3*sizePtr) + pSkins <- peekByteOff ptr (4*sizePtr) + pAnimations <- peekByteOff ptr (5*sizePtr) + vertices <- fmap S.fromList $ peekArray (numVertices*numFrames) pVerts + normals <- fmap S.fromList $ peekArray (numVertices*numFrames) pNormals + texCoords <- fmap S.fromList $ peekArray numTexCoords pTexCoords + triangles <- fmap S.fromList $ peekArray numTriangles pTriangles + skins <- fmap S.fromList $ peekArray numSkins pSkins + animations <- fmap S.fromList $ peekArray numAnimations pAnimations + return $ + Model vertices normals texCoords triangles skins animations + numFrames numVertices numTriangles numTexCoords numSkins numAnimations + + poke ptr + (Model verts normals texCoords tris skins animations + numFrames numVerts numTris numTex numSkins numAnimations) = + S.unsafeWith verts $ \pVerts -> + S.unsafeWith normals $ \pNormals -> + S.unsafeWith texCoords $ \pTexCoords -> + S.unsafeWith tris $ \pTris -> + S.unsafeWith skins $ \pSkins -> + S.unsafeWith animations $ \pAnimations -> do + #{poke Model, vertices} ptr pVerts + #{poke Model, normals} ptr pNormals + #{poke Model, texCoords} ptr pTexCoords + #{poke Model, triangles} ptr pTris + #{poke Model, skins} ptr pSkins + #{poke Model, animations} ptr pAnimations + #{poke Model, numFrames} ptr numFrames + #{poke Model, numVertices} ptr numVerts + #{poke Model, numTriangles} ptr numTris + #{poke Model, numTexCoords} ptr numTex + #{poke Model, numSkins} ptr numSkins + #{poke Model, numAnimations} ptr numAnimations + +-- | A model triangle. +-- +-- See also: 'triangles''. +data Triangle = Triangle + { v0 :: Vec3 + , v1 :: Vec3 + , v2 :: Vec3 + , n0 :: Vec3 + , n1 :: Vec3 + , n2 :: Vec3 + , t0 :: TexCoord + , t1 :: TexCoord + , t2 :: TexCoord + } + +instance Storable Triangle where + sizeOf _ = #{size model_triangle} + alignment _ = alignment (undefined :: Float) + + peek ptr = do + v0 <- #{peek model_triangle, v0} ptr + v1 <- #{peek model_triangle, v1} ptr + v2 <- #{peek model_triangle, v2} ptr + n0 <- #{peek model_triangle, n0} ptr + n1 <- #{peek model_triangle, n1} ptr + n2 <- #{peek model_triangle, n2} ptr + t0 <- #{peek model_triangle, t0} ptr + t1 <- #{peek model_triangle, t1} ptr + t2 <- #{peek model_triangle, t2} ptr + return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2 + + poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do + #{poke model_triangle, v0} ptr v0 + #{poke model_triangle, v1} ptr v1 + #{poke model_triangle, v2} ptr v2 + #{poke model_triangle, n0} ptr n0 + #{poke model_triangle, n1} ptr n1 + #{poke model_triangle, n2} ptr n2 + #{poke model_triangle, t0} ptr t0 + #{poke model_triangle, t1} ptr t1 + #{poke model_triangle, t2} ptr t2 + +foreign import ccall "Model.h model_free" + model_free :: Ptr Model -> IO () + +foreign import ccall "MD2_load.h MD2_load" + md2_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int + +foreign import ccall "OBJ_load.h OBJ_load" + obj_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int + +md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode +md2_load file clockwise leftHanded model = + md2_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code + +obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode +obj_load file clockwise leftHanded model = + obj_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code + +-- | Load the model specified by the given file. +loadModel :: FilePath -> Game s Model +loadModel file = do + dotPos <- case elemIndex '.' file of + Nothing -> gameError $ "file name has no extension: " ++ file + Just p -> return p + + let ext = map toLower . tail . snd $ splitAt dotPos file + + result <- gameIO . alloca $ \ptr -> do + status <- withCString file $ \fileCstr -> do + case ext of + "md2" -> md2_load fileCstr 0 0 ptr + "obj" -> obj_load fileCstr 0 0 ptr + _ -> return ModelNoSuitableLoader + + case status of + ModelSuccess -> do + model <- peek ptr + model_free ptr + return . Right $ model + ModelReadError -> return . Left $ "read error" + ModelMemoryAllocationError -> return . Left $ "memory allocation error" + ModelFileNotFound -> return . Left $ "file not found" + ModelFileMismatch -> return . Left $ "file mismatch" + ModelNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext + + case result of + Right model -> return model + Left err -> gameError $ "loadModel: " ++ err + +-- | Return 'True' if the model is animated, 'False' otherwise. +animated :: Model -> Bool +animated = (>1) . numFrames + +-- | Return the model's ith animation. +animation :: Model -> Int -> Animation +animation model i = animations model S.! i + +-- | Return the animation specified by the given string. +animationByName :: Model -> String -> Maybe Animation +animationByName model anim = + let anim' = B.pack anim in S.find ((==) anim' . name) $ animations model + +-- | Return a copy of the model's triangles. +triangles' :: Model -> IO [Triangle] +triangles' model = + let n = numVerts model * numFrames model + in with model $ \modelPtr -> + allocaArray n $ \arrayPtr -> do + model_copy_triangles modelPtr arrayPtr + tris <- peekArray n arrayPtr + return tris + +foreign import ccall "Model.h model_copy_triangles" + model_copy_triangles :: Ptr Model -> Ptr Triangle -> IO () + +-- | Transform the model's vertices. +transformVerts :: Model -> (Vec3 -> Vec3) -> Model +transformVerts model f = model { vertices = vertices' } + where + n = numVerts model * numFrames model + vertices' = S.generate n f' + f' i = f $ vertices model S.! i + +-- | Transform the model's normals. +transformNormals :: Model -> (Vec3 -> Vec3) -> Model +transformNormals model f = model { normals = normals' } + where + n = numVerts model * numFrames model + normals' = S.generate n f' + f' i = f $ normals model S.! i + +-- | Translate the model such that its lowest point has y = 0. +toGround :: Model -> IO Model +toGround model = + let model' = model { vertices = S.generate n $ \i -> vertices model S.! i } + n = numVerts model * numFrames model + in + with model' model_to_ground >> return model' + +foreign import ccall "Model.h model_to_ground" + model_to_ground :: Ptr Model -> IO () + +-- | Get the model's 3D bounding boxes. +modelBoxes :: Model -> IO (V.Vector Box) +modelBoxes model = + with model $ \modelPtr -> + allocaArray (numVerts model * numFrames model * 6) $ \pointsPtr -> do + model_compute_boxes modelPtr pointsPtr + let n = numFrames model + getBoxes = peekBoxes pointsPtr n 0 0 $ return [] + peekBoxes ptr n cur off l + | cur == n = l + | otherwise = do + xmin <- peekByteOff ptr off + ymin <- peekByteOff ptr $ off + sizeFloat + zmin <- peekByteOff ptr $ off + 2*sizeFloat + xmax <- peekByteOff ptr $ off + 3*sizeFloat + ymax <- peekByteOff ptr $ off + 4*sizeFloat + zmax <- peekByteOff ptr $ off + 5*sizeFloat + let pmin = Vec3 xmin ymin zmin + pmax = Vec3 xmax ymax zmax + box = Box pmin pmax + peekBoxes ptr n (cur+1) (off + 6*sizeFloat) $ fmap (box:) l + fmap (V.fromList . reverse) getBoxes + +foreign import ccall "Model.h model_compute_boxes" + 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 @@ -#include "MD2_load.h" -#include -#include -#include // malloc -#include // sqrt - -//! The MD2 magic number used to identify MD2 files. -#define MD2_ID 0x32504449 - -//! Limit values for the MD2 file format. -#define MD2_MAX_TRIANGLES 4096 -#define MD2_MAX_VERTICES 2048 -#define MD2_MAX_TEXCOORDS 2048 -#define MD2_MAX_FRAMES 512 -#define MD2_MAX_SKINS 32 - - -/// MD2 file header. -typedef struct -{ - I32 magic; /// The magic number "IDP2"; 844121161 in decimal; 0x32504449 - I32 version; /// Version number, always 8. - I32 skinWidth; /// Width of the skin(s) in pixels. - I32 skinHeight; /// Height of the skin(s) in pixels. - I32 frameSize; /// Size of a single frame in bytes. - I32 numSkins; /// Number of skins. - I32 numVertices; /// Number of vertices in a single frame. - I32 numTexCoords; /// Number of texture coordinates. - I32 numTriangles; /// Number of triangles. - I32 numGlCommands; /// Number of dwords in the Gl command list. - I32 numFrames; /// Number of frames. - I32 offsetSkins; /// Offset from the start of the file to the array of skins. - I32 offsetTexCoords; /// Offset from the start of the file to the array of texture coordinates. - I32 offsetTriangles; /// Offset from the start of the file to the array of triangles. - I32 offsetFrames; /// Offset from the start of the file to the array of frames. - I32 offsetGlCommands; /// Offset from the start of the file to the array of Gl commands. - I32 offsetEnd; /// Offset from the start of the file to the end of the file (the file size). -} -md2Header_t; - - -/// Represents a texture coordinate index. -typedef struct -{ - I16 s; - I16 t; -} -texCoord_t; - - -/// Represents a frame point. -typedef struct -{ - U8 x, y, z; - U8 lightNormalIndex; -} -vertex_t; - - -/// Represents a single frame. -typedef struct -{ - vec3 scale; - vec3 translate; - I8 name[16]; - vertex_t vertices[1]; -} -frame_t; - - -static void normalise (vec3* v) -{ - float x = v->x; - float y = v->y; - float z = v->z; - float mag = sqrt (x*x + y*y + z*z); - mag = mag == 0 ? 1 : mag; - v->x = x / mag; - v->y = y / mag; - v->z = z / mag; -} - - -static void cross (const vec3* a, const vec3* b, vec3* c) -{ - c->x = a->y * b->z - a->z * b->y; - c->y = a->z * b->x - a->x * b->z; - c->z = a->x * b->y - a->y * b->x; -} - - -static void vec3_sub (const vec3* a, const vec3* b, vec3* out) -{ - out->x = a->x - b->x; - out->y = a->y - b->y; - out->z = a->z - b->z; -} - - -static void normal (char clockwise, const vec3* p1, const vec3* p2, const vec3* p3, vec3* n) -{ - vec3 v1, v2; - if (clockwise) - { - vec3_sub (p3, p2, &v1); - vec3_sub (p1, p2, &v2); - } - else - { - vec3_sub (p1, p2, &v1); - vec3_sub (p3, p2, &v2); - } - cross (&v1, &v2, n); - normalise (n); -} - - -typedef struct -{ - vec3* normals; - vec3* base; - unsigned int N; -} -normal_map; - - -static void normal_map_initialise (normal_map* m, unsigned int N) -{ - m->N = N; -} - - -static void normal_map_clear (normal_map* m, vec3* normals, vec3* base) -{ - memset (normals, 0, m->N * sizeof(vec3)); - m->normals = normals; - m->base = base; -} - - -static void normal_map_insert (normal_map* m, vec3* vec, vec3 normal) -{ - unsigned int i = vec - m->base; - vec3* n = m->normals + i; - n->x += normal.x; - n->y += normal.y; - n->z += normal.z; -} - - -static void compute_normals (normal_map* m, char left_handed) -{ - vec3* n = m->normals; - unsigned int i; - for (i = 0; i < m->N; ++i) - { - if (!left_handed) - { - n->x = -n->x; - n->y = -n->y; - n->z = -n->z; - } - normalise (n); - n++; - } -} - - -static void safe_free (void* ptr) -{ - if (ptr) free (ptr); -} - - -static char frame_equal (const char* name1, const char* name2) -{ - char equal = 1; - int i; - - if (((name1 == 0) && (name2 != 0)) || ((name1 != 0) && (name2 == 0))) - { - return 0; - } - - for (i = 0; i < 16; ++i) - { - char c1 = *name1; - char c2 = *name2; - if ((c1 >= '0' && c1 <= '9') || (c2 >= '0' && c2 <= '9')) break; - if (c1 != c2) - { - equal = 0; - break; - } - if (c1 == '_' || c2 == '_') break; - name1++; - name2++; - } - return equal; -} - - -static void animation_remove_numbers (char* name) -{ - int i; - for (i = 0; i < 16; ++i) - { - char c = *name; - if (c == 0) break; - if (c >= '0' && c <= '9') *name = 0; - name++; - } -} - - -Model_error_code MD2_load (const char* filename, char clockwise, char left_handed, Model* model) -{ - FILE* filePtr; - vec3* vertices; - vec3* normals; - texCoord* texCoords; - triangle* triangles; - skin* skins; - animation* animations; - int i; - - // Open the file for reading. - filePtr = fopen(filename, "rb"); - if (!filePtr) return Model_File_Not_Found; - - // Make sure it is an MD2 file. - int magic; - if ((fread(&magic, 4, 1, filePtr)) != 1) - { - fclose(filePtr); - return Model_Read_Error; - } - - if (magic != MD2_ID) return Model_File_Mismatch; - - // Find out the file size. - long int fileSize; - fseek(filePtr, 0, SEEK_END); - fileSize = ftell(filePtr); - fseek(filePtr, 0, SEEK_SET); - - // Allocate a chunk of data to store the file in. - char *buffer = (char*) malloc(fileSize); - if (!buffer) - { - fclose(filePtr); - return Model_Memory_Allocation_Error; - } - - // Read the entire file into memory. - if ((fread(buffer, 1, fileSize, filePtr)) != (unsigned int)fileSize) - { - fclose(filePtr); - free(buffer); - return Model_Read_Error; - } - - // File stream is no longer needed. - fclose(filePtr); - - // Set a pointer to the header for parsing. - md2Header_t* header = (md2Header_t*) buffer; - - // Compute the number of animations. - unsigned numAnimations = 1; - int currentFrame; - const char* name = 0; - for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) - { - frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; - if (name == 0) - { - name = frame->name; - } - else if (!frame_equal(name, frame->name)) - { - numAnimations++; - name = frame->name; - } - } - - // Allocate memory for arrays. - vertices = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); - normals = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); - texCoords = (texCoord*) malloc(sizeof(texCoord) * header->numTexCoords); - triangles = (triangle*) malloc(sizeof(triangle) * header->numTriangles); - skins = (skin*) malloc(sizeof(skin) * header->numSkins); - animations = (animation*) malloc (numAnimations * sizeof(animation)); - - if (!vertices || !normals || !texCoords || !triangles || !skins || !animations) - { - safe_free (animations); - safe_free (skins); - safe_free (triangles); - safe_free (texCoords); - safe_free (normals); - safe_free (vertices); - free (buffer); - return Model_Memory_Allocation_Error; - } - - // Load the model's vertices. - // Loop through each frame, grab the vertices that make it up, transform them back - // to their real coordinates and store them in the model's vertex array. - for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) - { - // Set a frame pointer to the current frame. - frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; - - // Set a vertex pointer to the model's vertex array, at the appropiate position. - vec3* vert = &vertices[currentFrame * header->numVertices]; - - // Now parse those vertices and transform them back. - int currentVertex; - for (currentVertex = 0; currentVertex != header->numVertices; ++currentVertex) - { - vert[currentVertex].x = frame->vertices[currentVertex].x * frame->scale.x + frame->translate.x; - vert[currentVertex].y = frame->vertices[currentVertex].y * frame->scale.y + frame->translate.y; - vert[currentVertex].z = frame->vertices[currentVertex].z * frame->scale.z + frame->translate.z; - } - } - - // Load the model's triangles. - - // Set a pointer to the triangles array in the buffer. - triangle* t = (triangle*) &buffer[header->offsetTriangles]; - - if (clockwise) - { - for (i = 0; i < header->numTriangles; ++i) - { - triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; - triangles[i].vertexIndices[1] = t[i].vertexIndices[1]; - triangles[i].vertexIndices[2] = t[i].vertexIndices[2]; - - triangles[i].textureIndices[0] = t[i].textureIndices[0]; - triangles[i].textureIndices[1] = t[i].textureIndices[1]; - triangles[i].textureIndices[2] = t[i].textureIndices[2]; - } - } - else - { - for (i = 0; i < header->numTriangles; ++i) - { - triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; - triangles[i].vertexIndices[1] = t[i].vertexIndices[2]; - triangles[i].vertexIndices[2] = t[i].vertexIndices[1]; - - triangles[i].textureIndices[0] = t[i].textureIndices[0]; - triangles[i].textureIndices[1] = t[i].textureIndices[2]; - triangles[i].textureIndices[2] = t[i].textureIndices[1]; - } - } - - // Load the texture coordinates. - float sw = (float) header->skinWidth; - float sh = (float) header->skinHeight; - texCoord_t* texc = (texCoord_t*) &buffer[header->offsetTexCoords]; - for (i = 0; i < header->numTexCoords; ++i) - { - texCoords[i].s = (float)texc->s / sw; - texCoords[i].t = 1.0f - (float)texc->t / sh; - texc++; - } - - // Iterate over every frame and compute normals for every triangle. - vec3 n; - - normal_map map; - normal_map_initialise (&map, header->numVertices); - - for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) - { - // Set a pointer to the triangle array. - triangle* t = triangles; - - // Set a pointer to the vertex array at the appropiate position. - vec3* vertex_array = vertices + header->numVertices * currentFrame; - - // Set a pointer to the normals array at the appropiate position. - vec3* normals_ptr = normals + header->numVertices * currentFrame; - - normal_map_clear (&map, normals_ptr, vertex_array); - - for (i = 0; i < header->numTriangles; ++i) - { - // Compute face normal. - vec3* v0 = &vertex_array[t->vertexIndices[0]]; - vec3* v1 = &vertex_array[t->vertexIndices[1]]; - vec3* v2 = &vertex_array[t->vertexIndices[2]]; - normal (clockwise, v0, v1, v2, &n); - - // Add face normal to each of the face's vertices. - normal_map_insert (&map, v0, n); - normal_map_insert (&map, v1, n); - normal_map_insert (&map, v2, n); - - t++; - } - - compute_normals (&map, left_handed); - } - - // Load the model's skins. - const skin* s = (const skin*) &buffer[header->offsetSkins]; - for (i = 0; i < header->numSkins; ++i) - { - memcpy (skins[i].name, s->name, 64); - s++; - } - - // Load the model's animations. - unsigned start = 0; - name = 0; - animation* currentAnimation = animations; - for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) - { - frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; - if (name == 0) - { - name = frame->name; - } - else if (!frame_equal(name, frame->name)) - { - memcpy (currentAnimation->name, name, 16); - animation_remove_numbers (currentAnimation->name); - currentAnimation->start = start; - currentAnimation->end = currentFrame-1; - if (currentAnimation != animations) - { - animation* prev = currentAnimation; - prev--; - prev->end = start-1; - } - name = frame->name; - currentAnimation++; - start = currentFrame; - } - } - currentAnimation = animations + numAnimations - 1; - memcpy (currentAnimation->name, name, 16); - animation_remove_numbers (currentAnimation->name); - currentAnimation->start = start; - currentAnimation->end = header->numFrames-1; - - /*printf ("finished loading model %s\n", filename); - printf ("numAnimations: %u\n", numAnimations); - printf ("animations: %p\n", animations); - - currentAnimation = animations; - for (i = 0; i < numAnimations; ++i) - { - printf ("Animation %d, name: %s, start: %d, end %d\n", - i, currentAnimation->name, currentAnimation->start, currentAnimation->end); - currentAnimation++; - }*/ - - model->vertices = vertices; - model->normals = normals; - model->texCoords = texCoords; - model->triangles = triangles; - model->skins = skins; - model->animations = animations; - - model->numFrames = header->numFrames; - model->numVertices = header->numVertices; - model->numTriangles = header->numTriangles; - model->numTexCoords = header->numTexCoords; - model->numSkins = header->numSkins; - model->numAnimations = numAnimations; - - free(buffer); - - return Model_Success; -} +#include "MD2_load.h" +#include +#include +#include // malloc +#include // sqrt + +//! The MD2 magic number used to identify MD2 files. +#define MD2_ID 0x32504449 + +//! Limit values for the MD2 file format. +#define MD2_MAX_TRIANGLES 4096 +#define MD2_MAX_VERTICES 2048 +#define MD2_MAX_TEXCOORDS 2048 +#define MD2_MAX_FRAMES 512 +#define MD2_MAX_SKINS 32 + + +/// MD2 file header. +typedef struct +{ + I32 magic; /// The magic number "IDP2"; 844121161 in decimal; 0x32504449 + I32 version; /// Version number, always 8. + I32 skinWidth; /// Width of the skin(s) in pixels. + I32 skinHeight; /// Height of the skin(s) in pixels. + I32 frameSize; /// Size of a single frame in bytes. + I32 numSkins; /// Number of skins. + I32 numVertices; /// Number of vertices in a single frame. + I32 numTexCoords; /// Number of texture coordinates. + I32 numTriangles; /// Number of triangles. + I32 numGlCommands; /// Number of dwords in the Gl command list. + I32 numFrames; /// Number of frames. + I32 offsetSkins; /// Offset from the start of the file to the array of skins. + I32 offsetTexCoords; /// Offset from the start of the file to the array of texture coordinates. + I32 offsetTriangles; /// Offset from the start of the file to the array of triangles. + I32 offsetFrames; /// Offset from the start of the file to the array of frames. + I32 offsetGlCommands; /// Offset from the start of the file to the array of Gl commands. + I32 offsetEnd; /// Offset from the start of the file to the end of the file (the file size). +} +md2Header_t; + + +/// Represents a texture coordinate index. +typedef struct +{ + I16 s; + I16 t; +} +texCoord_t; + + +/// Represents a frame point. +typedef struct +{ + U8 x, y, z; + U8 lightNormalIndex; +} +vertex_t; + + +/// Represents a single frame. +typedef struct +{ + vec3 scale; + vec3 translate; + I8 name[16]; + vertex_t vertices[1]; +} +frame_t; + + +static void normalise (vec3* v) +{ + float x = v->x; + float y = v->y; + float z = v->z; + float mag = sqrt (x*x + y*y + z*z); + mag = mag == 0 ? 1 : mag; + v->x = x / mag; + v->y = y / mag; + v->z = z / mag; +} + + +static void cross (const vec3* a, const vec3* b, vec3* c) +{ + c->x = a->y * b->z - a->z * b->y; + c->y = a->z * b->x - a->x * b->z; + c->z = a->x * b->y - a->y * b->x; +} + + +static void vec3_sub (const vec3* a, const vec3* b, vec3* out) +{ + out->x = a->x - b->x; + out->y = a->y - b->y; + out->z = a->z - b->z; +} + + +static void normal (char clockwise, const vec3* p1, const vec3* p2, const vec3* p3, vec3* n) +{ + vec3 v1, v2; + if (clockwise) + { + vec3_sub (p3, p2, &v1); + vec3_sub (p1, p2, &v2); + } + else + { + vec3_sub (p1, p2, &v1); + vec3_sub (p3, p2, &v2); + } + cross (&v1, &v2, n); + normalise (n); +} + + +typedef struct +{ + vec3* normals; + vec3* base; + unsigned int N; +} +normal_map; + + +static void normal_map_initialise (normal_map* m, unsigned int N) +{ + m->N = N; +} + + +static void normal_map_clear (normal_map* m, vec3* normals, vec3* base) +{ + memset (normals, 0, m->N * sizeof(vec3)); + m->normals = normals; + m->base = base; +} + + +static void normal_map_insert (normal_map* m, vec3* vec, vec3 normal) +{ + unsigned int i = vec - m->base; + vec3* n = m->normals + i; + n->x += normal.x; + n->y += normal.y; + n->z += normal.z; +} + + +static void compute_normals (normal_map* m, char left_handed) +{ + vec3* n = m->normals; + unsigned int i; + for (i = 0; i < m->N; ++i) + { + if (!left_handed) + { + n->x = -n->x; + n->y = -n->y; + n->z = -n->z; + } + normalise (n); + n++; + } +} + + +static void safe_free (void* ptr) +{ + if (ptr) free (ptr); +} + + +static char frame_equal (const char* name1, const char* name2) +{ + char equal = 1; + int i; + + if (((name1 == 0) && (name2 != 0)) || ((name1 != 0) && (name2 == 0))) + { + return 0; + } + + for (i = 0; i < 16; ++i) + { + char c1 = *name1; + char c2 = *name2; + if ((c1 >= '0' && c1 <= '9') || (c2 >= '0' && c2 <= '9')) break; + if (c1 != c2) + { + equal = 0; + break; + } + if (c1 == '_' || c2 == '_') break; + name1++; + name2++; + } + return equal; +} + + +static void animation_remove_numbers (char* name) +{ + int i; + for (i = 0; i < 16; ++i) + { + char c = *name; + if (c == 0) break; + if (c >= '0' && c <= '9') *name = 0; + name++; + } +} + + +Model_error_code MD2_load (const char* filename, char clockwise, char left_handed, Model* model) +{ + FILE* filePtr; + vec3* vertices; + vec3* normals; + texCoord* texCoords; + triangle* triangles; + skin* skins; + animation* animations; + int i; + + // Open the file for reading. + filePtr = fopen(filename, "rb"); + if (!filePtr) return Model_File_Not_Found; + + // Make sure it is an MD2 file. + int magic; + if ((fread(&magic, 4, 1, filePtr)) != 1) + { + fclose(filePtr); + return Model_Read_Error; + } + + if (magic != MD2_ID) return Model_File_Mismatch; + + // Find out the file size. + long int fileSize; + fseek(filePtr, 0, SEEK_END); + fileSize = ftell(filePtr); + fseek(filePtr, 0, SEEK_SET); + + // Allocate a chunk of data to store the file in. + char *buffer = (char*) malloc(fileSize); + if (!buffer) + { + fclose(filePtr); + return Model_Memory_Allocation_Error; + } + + // Read the entire file into memory. + if ((fread(buffer, 1, fileSize, filePtr)) != (unsigned int)fileSize) + { + fclose(filePtr); + free(buffer); + return Model_Read_Error; + } + + // File stream is no longer needed. + fclose(filePtr); + + // Set a pointer to the header for parsing. + md2Header_t* header = (md2Header_t*) buffer; + + // Compute the number of animations. + unsigned numAnimations = 1; + int currentFrame; + const char* name = 0; + for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) + { + frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; + if (name == 0) + { + name = frame->name; + } + else if (!frame_equal(name, frame->name)) + { + numAnimations++; + name = frame->name; + } + } + + // Allocate memory for arrays. + vertices = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); + normals = (vec3*) malloc(sizeof(vec3) * header->numVertices * header->numFrames); + texCoords = (texCoord*) malloc(sizeof(texCoord) * header->numTexCoords); + triangles = (triangle*) malloc(sizeof(triangle) * header->numTriangles); + skins = (skin*) malloc(sizeof(skin) * header->numSkins); + animations = (animation*) malloc (numAnimations * sizeof(animation)); + + if (!vertices || !normals || !texCoords || !triangles || !skins || !animations) + { + safe_free (animations); + safe_free (skins); + safe_free (triangles); + safe_free (texCoords); + safe_free (normals); + safe_free (vertices); + free (buffer); + return Model_Memory_Allocation_Error; + } + + // Load the model's vertices. + // Loop through each frame, grab the vertices that make it up, transform them back + // to their real coordinates and store them in the model's vertex array. + for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) + { + // Set a frame pointer to the current frame. + frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; + + // Set a vertex pointer to the model's vertex array, at the appropiate position. + vec3* vert = &vertices[currentFrame * header->numVertices]; + + // Now parse those vertices and transform them back. + int currentVertex; + for (currentVertex = 0; currentVertex != header->numVertices; ++currentVertex) + { + vert[currentVertex].x = frame->vertices[currentVertex].x * frame->scale.x + frame->translate.x; + vert[currentVertex].y = frame->vertices[currentVertex].y * frame->scale.y + frame->translate.y; + vert[currentVertex].z = frame->vertices[currentVertex].z * frame->scale.z + frame->translate.z; + } + } + + // Load the model's triangles. + + // Set a pointer to the triangles array in the buffer. + triangle* t = (triangle*) &buffer[header->offsetTriangles]; + + if (clockwise) + { + for (i = 0; i < header->numTriangles; ++i) + { + triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; + triangles[i].vertexIndices[1] = t[i].vertexIndices[1]; + triangles[i].vertexIndices[2] = t[i].vertexIndices[2]; + + triangles[i].textureIndices[0] = t[i].textureIndices[0]; + triangles[i].textureIndices[1] = t[i].textureIndices[1]; + triangles[i].textureIndices[2] = t[i].textureIndices[2]; + } + } + else + { + for (i = 0; i < header->numTriangles; ++i) + { + triangles[i].vertexIndices[0] = t[i].vertexIndices[0]; + triangles[i].vertexIndices[1] = t[i].vertexIndices[2]; + triangles[i].vertexIndices[2] = t[i].vertexIndices[1]; + + triangles[i].textureIndices[0] = t[i].textureIndices[0]; + triangles[i].textureIndices[1] = t[i].textureIndices[2]; + triangles[i].textureIndices[2] = t[i].textureIndices[1]; + } + } + + // Load the texture coordinates. + float sw = (float) header->skinWidth; + float sh = (float) header->skinHeight; + texCoord_t* texc = (texCoord_t*) &buffer[header->offsetTexCoords]; + for (i = 0; i < header->numTexCoords; ++i) + { + texCoords[i].s = (float)texc->s / sw; + texCoords[i].t = 1.0f - (float)texc->t / sh; + texc++; + } + + // Iterate over every frame and compute normals for every triangle. + vec3 n; + + normal_map map; + normal_map_initialise (&map, header->numVertices); + + for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) + { + // Set a pointer to the triangle array. + triangle* t = triangles; + + // Set a pointer to the vertex array at the appropiate position. + vec3* vertex_array = vertices + header->numVertices * currentFrame; + + // Set a pointer to the normals array at the appropiate position. + vec3* normals_ptr = normals + header->numVertices * currentFrame; + + normal_map_clear (&map, normals_ptr, vertex_array); + + for (i = 0; i < header->numTriangles; ++i) + { + // Compute face normal. + vec3* v0 = &vertex_array[t->vertexIndices[0]]; + vec3* v1 = &vertex_array[t->vertexIndices[1]]; + vec3* v2 = &vertex_array[t->vertexIndices[2]]; + normal (clockwise, v0, v1, v2, &n); + + // Add face normal to each of the face's vertices. + normal_map_insert (&map, v0, n); + normal_map_insert (&map, v1, n); + normal_map_insert (&map, v2, n); + + t++; + } + + compute_normals (&map, left_handed); + } + + // Load the model's skins. + const skin* s = (const skin*) &buffer[header->offsetSkins]; + for (i = 0; i < header->numSkins; ++i) + { + memcpy (skins[i].name, s->name, 64); + s++; + } + + // Load the model's animations. + unsigned start = 0; + name = 0; + animation* currentAnimation = animations; + for (currentFrame = 0; currentFrame < header->numFrames; ++currentFrame) + { + frame_t* frame = (frame_t*) &buffer[header->offsetFrames + currentFrame * header->frameSize]; + if (name == 0) + { + name = frame->name; + } + else if (!frame_equal(name, frame->name)) + { + memcpy (currentAnimation->name, name, 16); + animation_remove_numbers (currentAnimation->name); + currentAnimation->start = start; + currentAnimation->end = currentFrame-1; + if (currentAnimation != animations) + { + animation* prev = currentAnimation; + prev--; + prev->end = start-1; + } + name = frame->name; + currentAnimation++; + start = currentFrame; + } + } + currentAnimation = animations + numAnimations - 1; + memcpy (currentAnimation->name, name, 16); + animation_remove_numbers (currentAnimation->name); + currentAnimation->start = start; + currentAnimation->end = header->numFrames-1; + + /*printf ("finished loading model %s\n", filename); + printf ("numAnimations: %u\n", numAnimations); + printf ("animations: %p\n", animations); + + currentAnimation = animations; + for (i = 0; i < numAnimations; ++i) + { + printf ("Animation %d, name: %s, start: %d, end %d\n", + i, currentAnimation->name, currentAnimation->start, currentAnimation->end); + currentAnimation++; + }*/ + + model->vertices = vertices; + model->normals = normals; + model->texCoords = texCoords; + model->triangles = triangles; + model->skins = skins; + model->animations = animations; + + model->numFrames = header->numFrames; + model->numVertices = header->numVertices; + model->numTriangles = header->numTriangles; + model->numTexCoords = header->numTexCoords; + model->numSkins = header->numSkins; + model->numAnimations = numAnimations; + + free(buffer); + + return Model_Success; +} 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 @@ -#include "Model.h" -#include // free -#include - - -#define TO_RAD M_PI / 180.0 - - -static void safe_free (void* ptr) -{ - if (ptr) - { - free (ptr); - ptr = 0; - } -} - - -void model_free (Model* model) -{ - safe_free (model->vertices); - safe_free (model->normals); - safe_free (model->texCoords); - safe_free (model->triangles); - safe_free (model->skins); - safe_free (model->animations); -} - - -void model_to_ground (Model* model) -{ - unsigned i, f; - vec3* v = model->vertices; - - // Compute the minimum y coordinate for each frame and translate - // the model appropriately. - for (f = 0; f < model->numFrames; ++f) - { - vec3* w = v; - float y = v->y; - - for (i = 0; i < model->numVertices; ++i, ++v) - { - y = fmin (y, v->y); - } - - v = w; - for (i = 0; i < model->numVertices; ++i, ++v) - { - v->y -= y; - } - } -} - - -void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris) -{ - int i; - int j = model->numVertices; - - vec3* v = model->vertices + j * frame; - vec3* n = model->normals + j * frame; - texCoord* t = model->texCoords; - triangle* tri = model->triangles; - - - for (i = 0; i < j; ++i, ++tri, ++tris) - { - tris->v0 = v[tri->vertexIndices[0]]; - tris->v1 = v[tri->vertexIndices[1]]; - tris->v2 = v[tri->vertexIndices[2]]; - - tris->n0 = n[tri->vertexIndices[0]]; - tris->n1 = n[tri->vertexIndices[1]]; - tris->n2 = n[tri->vertexIndices[2]]; - - tris->t0 = t[tri->textureIndices[0]]; - tris->t1 = t[tri->textureIndices[1]]; - tris->t2 = t[tri->textureIndices[2]]; - } -} - - -void model_compute_boxes (Model* model, float* points) -{ - vec3* v = model->vertices; - - unsigned f; - for (f = 0; f < model->numFrames; ++f) - { - float xmin = v->x; - float xmax = v->x; - float ymin = v->y; - float ymax = v->y; - float zmin = v->z; - float zmax = v->z; - - unsigned i; - for (i = 0; i < model->numVertices; ++i, ++v) - { - xmin = fmin (xmin, v->x); - ymin = fmin (ymin, v->y); - zmin = fmin (zmin, v->z); - xmax = fmax (xmax, v->x); - ymax = fmax (ymax, v->y); - zmax = fmax (zmax, v->z); - } - - *points++ = xmin; *points++ = ymin; *points++ = zmin; - *points++ = xmax; *points++ = ymax; *points++ = zmax; - } -} +#include "Model.h" +#include // free +#include + + +#define TO_RAD M_PI / 180.0 + + +static void safe_free (void* ptr) +{ + if (ptr) + { + free (ptr); + ptr = 0; + } +} + + +void model_free (Model* model) +{ + safe_free (model->vertices); + safe_free (model->normals); + safe_free (model->texCoords); + safe_free (model->triangles); + safe_free (model->skins); + safe_free (model->animations); +} + + +void model_to_ground (Model* model) +{ + unsigned i, f; + vec3* v = model->vertices; + + // Compute the minimum y coordinate for each frame and translate + // the model appropriately. + for (f = 0; f < model->numFrames; ++f) + { + vec3* w = v; + float y = v->y; + + for (i = 0; i < model->numVertices; ++i, ++v) + { + y = fmin (y, v->y); + } + + v = w; + for (i = 0; i < model->numVertices; ++i, ++v) + { + v->y -= y; + } + } +} + + +void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris) +{ + int i; + int j = model->numVertices; + + vec3* v = model->vertices + j * frame; + vec3* n = model->normals + j * frame; + texCoord* t = model->texCoords; + triangle* tri = model->triangles; + + + for (i = 0; i < j; ++i, ++tri, ++tris) + { + tris->v0 = v[tri->vertexIndices[0]]; + tris->v1 = v[tri->vertexIndices[1]]; + tris->v2 = v[tri->vertexIndices[2]]; + + tris->n0 = n[tri->vertexIndices[0]]; + tris->n1 = n[tri->vertexIndices[1]]; + tris->n2 = n[tri->vertexIndices[2]]; + + tris->t0 = t[tri->textureIndices[0]]; + tris->t1 = t[tri->textureIndices[1]]; + tris->t2 = t[tri->textureIndices[2]]; + } +} + + +void model_compute_boxes (Model* model, float* points) +{ + vec3* v = model->vertices; + + unsigned f; + for (f = 0; f < model->numFrames; ++f) + { + float xmin = v->x; + float xmax = v->x; + float ymin = v->y; + float ymax = v->y; + float zmin = v->z; + float zmax = v->z; + + unsigned i; + for (i = 0; i < model->numVertices; ++i, ++v) + { + xmin = fmin (xmin, v->x); + ymin = fmin (ymin, v->y); + zmin = fmin (zmin, v->z); + xmax = fmax (xmax, v->x); + ymax = fmax (ymax, v->y); + zmax = fmax (zmax, v->z); + } + + *points++ = xmin; *points++ = ymin; *points++ = zmin; + *points++ = xmax; *points++ = ymax; *points++ = zmax; + } +} 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 @@ -#ifndef _SPEAR_MODEL_H -#define _SPEAR_MODEL_H - -#include "sys_types.h" - - -typedef struct -{ - char name[64]; -} -skin; - - -typedef struct -{ - float x, y, z; -} -vec3; - - -typedef struct -{ - float s, t; -} -texCoord; - - -typedef struct -{ - U16 vertexIndices[3]; - U16 textureIndices[3]; -} -triangle; - - -typedef struct -{ - char name[16]; - unsigned int start; - unsigned int end; -} -animation; - - -typedef struct -{ - vec3* vertices; // One array per frame. - vec3* normals; // One array per frame. One normal per vertex per frame. - texCoord* texCoords; // One array for all frames. - triangle* triangles; // One array for all frames. - skin* skins; // Holds the model's texture files. - animation* animations; // Holds the model's animations. - - unsigned int numFrames; - unsigned int numVertices; // Number of vertices per frame. - unsigned int numTriangles; // Number of triangles in one frame. - unsigned int numTexCoords; // Number of texture coordinates in one frame. - unsigned int numSkins; - unsigned int numAnimations; -} -Model; - - -typedef struct -{ - vec3 v0; - vec3 v1; - vec3 v2; - vec3 n0; - vec3 n1; - vec3 n2; - texCoord t0; - texCoord t1; - texCoord t2; -} -model_triangle; - - -#ifdef __cplusplus -extern "C" { -#endif - -/// Frees the given Model from memory. -/// The 'model' pointer itself is not freed. -void model_free (Model* model); - -/// Translate the Model such that its lowest point has y = 0. -void model_to_ground (Model* model); - -/// Copy the triangles of the given frame from the Model into the given array. -void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris); - -/// Compute the model's 2d AABBs. -void model_compute_boxes (Model* model, float* points); - -#ifdef __cplusplus -} -#endif - -#endif // _SPEAR_MODEL_H +#ifndef _SPEAR_MODEL_H +#define _SPEAR_MODEL_H + +#include "sys_types.h" + + +typedef struct +{ + char name[64]; +} +skin; + + +typedef struct +{ + float x, y, z; +} +vec3; + + +typedef struct +{ + float s, t; +} +texCoord; + + +typedef struct +{ + U16 vertexIndices[3]; + U16 textureIndices[3]; +} +triangle; + + +typedef struct +{ + char name[16]; + unsigned int start; + unsigned int end; +} +animation; + + +typedef struct +{ + vec3* vertices; // One array per frame. + vec3* normals; // One array per frame. One normal per vertex per frame. + texCoord* texCoords; // One array for all frames. + triangle* triangles; // One array for all frames. + skin* skins; // Holds the model's texture files. + animation* animations; // Holds the model's animations. + + unsigned int numFrames; + unsigned int numVertices; // Number of vertices per frame. + unsigned int numTriangles; // Number of triangles in one frame. + unsigned int numTexCoords; // Number of texture coordinates in one frame. + unsigned int numSkins; + unsigned int numAnimations; +} +Model; + + +typedef struct +{ + vec3 v0; + vec3 v1; + vec3 v2; + vec3 n0; + vec3 n1; + vec3 n2; + texCoord t0; + texCoord t1; + texCoord t2; +} +model_triangle; + + +#ifdef __cplusplus +extern "C" { +#endif + +/// Frees the given Model from memory. +/// The 'model' pointer itself is not freed. +void model_free (Model* model); + +/// Translate the Model such that its lowest point has y = 0. +void model_to_ground (Model* model); + +/// Copy the triangles of the given frame from the Model into the given array. +void model_copy_triangles (Model* model, unsigned frame, model_triangle* tris); + +/// Compute the model's 2d AABBs. +void model_compute_boxes (Model* model, float* points); + +#ifdef __cplusplus +} +#endif + +#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 @@ -#ifndef _SPEAR_MODEL_ERROR_CODE_H -#define _SPEAR_MODEL_ERROR_CODE_H - -typedef enum -{ - Model_Success, - Model_Read_Error, - Model_Memory_Allocation_Error, - Model_File_Not_Found, - Model_File_Mismatch, - Model_No_Suitable_Loader, -} -Model_error_code; - -#endif // _SPEAR_MODEL_ERROR_CODE_H - +#ifndef _SPEAR_MODEL_ERROR_CODE_H +#define _SPEAR_MODEL_ERROR_CODE_H + +typedef enum +{ + Model_Success, + Model_Read_Error, + Model_Memory_Allocation_Error, + Model_File_Not_Found, + Model_File_Mismatch, + Model_No_Suitable_Loader, +} +Model_error_code; + +#endif // _SPEAR_MODEL_ERROR_CODE_H + 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 @@ -test: ../Model.o OBJ_load.o cvector.o test.o - $(CC) Model.o OBJ_load.o cvector.o test.o -o $@ -lm - -vector: cvector.o vector-test.o - $(CC) cvector.o vector-test.o -o vector - - -%.o: %.c %.h - $(CC) -g -c $< - - -clean: - @rm -f test vector - @rm -f *.o - +test: ../Model.o OBJ_load.o cvector.o test.o + $(CC) Model.o OBJ_load.o cvector.o test.o -o $@ -lm + +vector: cvector.o vector-test.o + $(CC) cvector.o vector-test.o -o vector + + +%.o: %.c %.h + $(CC) -g -c $< + + +clean: + @rm -f test vector + @rm -f *.o + 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 @@ -#include "OBJ_load.h" -#include "cvector.h" -#include -#include // free -#include // memcpy -#include // sqrt - - -char lastError [128]; - - -static void safe_free (void* ptr) -{ - if (ptr) - { - free (ptr); - ptr = 0; - } -} - - -static void cross (vec3 a, vec3 b, vec3* c) -{ - c->x = a.y * b.z - a.z * b.y; - c->y = a.z * b.x - a.x * b.z; - c->z = a.x * b.y - a.y * b.x; -} - - -static void vec3_sub (vec3 a, vec3 b, vec3* out) -{ - out->x = a.x - b.x; - out->y = a.y - b.y; - out->z = a.z - b.z; -} - - -static void compute_normal (char clockwise, vec3 p1, vec3 p2, vec3 p3, vec3* n) -{ - vec3 v1, v2; - if (!clockwise) - { - vec3_sub (p3, p2, &v1); - vec3_sub (p1, p2, &v2); - } - else - { - vec3_sub (p1, p2, &v1); - vec3_sub (p3, p2, &v2); - } - cross (v1, v2, n); -} - - -static void normalise (vec3* v) -{ - float x = v->x; - float y = v->y; - float z = v->z; - float mag = sqrt (x*x + y*y + z*z); - mag = mag == 0.0f ? 1.0f : mag; - v->x /= mag; - v->y /= mag; - v->z /= mag; -} - - -static void vec3_add (vec3 a, vec3* b) -{ - b->x += a.x; - b->y += a.y; - b->z += a.z; -} - - -static void read_vertex (FILE* file, vec3* vert) -{ - fscanf (file, "%f %f", &vert->x, &vert->y); - if (fscanf(file, "%f", &vert->z) == 0) vert->z = 0.0f; -} - - -static void read_normal (FILE* file, vec3* normal) -{ - fscanf (file, "%f %f %f", &normal->x, &normal->y, &normal->z); -} - - -static void read_tex_coord (FILE* file, texCoord* texc) -{ - fscanf (file, "%f %f", &texc->s, &texc->t); -} - - -static void read_face (FILE* file, - char clockwise, - vector* vertices, - vector* normals, - vector* triangles) -{ - vector idxs; - vector texCoords; - - vector_new (&idxs, sizeof(int), 4); - vector_new (&texCoords, sizeof(int), 4); - - unsigned int index; - unsigned int normal; - unsigned int texc; - - fscanf (file, "f"); - - while (!feof(file) && fscanf(file, "%d", &index) > 0) - { - vector_append (&idxs, &index); - - if (fgetc (file) == '/') - { - fscanf (file, "%d", &texc); - vector_append (&texCoords, &texc); - } - else fseek (file, -1, SEEK_CUR); - - if (fgetc (file) == '/') - { - fscanf (file, "%d", &normal); - } - else fseek (file, -1, SEEK_CUR); - } - - // Triangulate the face and add its triangles to the triangles vector. - triangle tri; - tri.vertexIndices[0] = *((int*) vector_ith (&idxs, 0)) - 1; - tri.textureIndices[0] = *((int*) vector_ith (&texCoords, 0)) - 1; - - int i; - for (i = 1; i < vector_size(&idxs)-1; i++) - { - tri.vertexIndices[1] = *((int*) vector_ith (&idxs, i)) - 1; - tri.textureIndices[1] = *((int*) vector_ith (&texCoords, i)) - 1; - tri.vertexIndices[2] = *((int*) vector_ith (&idxs, i+1)) - 1; - tri.textureIndices[2] = *((int*) vector_ith (&texCoords, i+1)) - 1; - vector_append (triangles, &tri); - } - - // Compute face normal and add contribution to each of the face's vertices. - unsigned int i0 = tri.vertexIndices[0]; - unsigned int i1 = tri.vertexIndices[1]; - unsigned int i2 = tri.vertexIndices[2]; - - vec3 n; - vec3 v0 = *((vec3*) vector_ith (vertices, i0)); - vec3 v1 = *((vec3*) vector_ith (vertices, i1)); - vec3 v2 = *((vec3*) vector_ith (vertices, i2)); - compute_normal (clockwise, v0, v1, v2, &n); - - for (i = 0; i < vector_size (&idxs); i++) - { - int j = *((int*) vector_ith (&idxs, i)) - 1; - vec3* normal = (vec3*) vector_ith (normals, j); - vec3_add (n, normal); - } - - vector_free (&idxs); - vector_free (&texCoords); -} - - -Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model) -{ - vec3* norms = 0; - vec3* verts = 0; - texCoord* texcs = 0; - triangle* tris = 0; - - FILE* file = fopen (filename, "r"); - if (file == NULL) return Model_File_Not_Found; - - vec3 vert; - vec3 normal; - texCoord texc; - - vector vertices; - vector normals; - vector texCoords; - vector triangles; - - int result = vector_new (&vertices, sizeof(vec3), 0) - | vector_new (&normals, sizeof(vec3), 0) - | vector_new (&texCoords, sizeof(texCoord), 0) - | vector_new (&triangles, sizeof(triangle), 0); - - if (result != 0) - { - safe_free (vertices.data); - safe_free (normals.data); - safe_free (texCoords.data); - safe_free (triangles.data); - return Model_Memory_Allocation_Error; - } - - while (!feof(file)) - { - switch (fgetc(file)) - { - case 'v': - switch (fgetc(file)) - { - case 't': - read_tex_coord (file, &texc); - vector_append (&texCoords, &texc); - break; - - case 'n': - read_normal (file, &normal); - vector_append (&normals, &normal); - break; - - default: - read_vertex (file, &vert); - vector_append (&vertices, &vert); - break; - } - break; - - case 'f': - // Initialise the normals vector if it is empty. - if (vector_size(&normals) == 0) - { - vec3 zero; - zero.x = 0.0f; zero.y = 0.0f; zero.z = 0.0f; - vector_new (&normals, sizeof(vec3), vector_size(&vertices)); - vector_initialise (&normals, &zero); - } - read_face (file, clockwise, &vertices, &normals, &triangles); - break; - - case '#': - { - int x = 17; - while (x != '\n' && x != EOF) x = fgetc(file); - break; - } - - default: break; - } - } - - fclose (file); - - unsigned numVertices = vector_size (&vertices); - - // Normalise normals. - unsigned i; - for (i = 0; i < numVertices; ++i) - { - normalise (vector_ith (&normals, i)); - } - - model->vertices = (vec3*) vertices.data; - model->normals = (vec3*) normals.data; - model->texCoords = (texCoord*) texCoords.data; - model->triangles = (triangle*) triangles.data; - model->skins = 0; - model->animations = 0; - model->numFrames = 1; - model->numVertices = numVertices; - model->numTriangles = vector_size (&triangles); - model->numTexCoords = vector_size (&texCoords); - model->numSkins = 0; - model->numAnimations = 0; - - return Model_Success; -} +#include "OBJ_load.h" +#include "cvector.h" +#include +#include // free +#include // memcpy +#include // sqrt + + +char lastError [128]; + + +static void safe_free (void* ptr) +{ + if (ptr) + { + free (ptr); + ptr = 0; + } +} + + +static void cross (vec3 a, vec3 b, vec3* c) +{ + c->x = a.y * b.z - a.z * b.y; + c->y = a.z * b.x - a.x * b.z; + c->z = a.x * b.y - a.y * b.x; +} + + +static void vec3_sub (vec3 a, vec3 b, vec3* out) +{ + out->x = a.x - b.x; + out->y = a.y - b.y; + out->z = a.z - b.z; +} + + +static void compute_normal (char clockwise, vec3 p1, vec3 p2, vec3 p3, vec3* n) +{ + vec3 v1, v2; + if (!clockwise) + { + vec3_sub (p3, p2, &v1); + vec3_sub (p1, p2, &v2); + } + else + { + vec3_sub (p1, p2, &v1); + vec3_sub (p3, p2, &v2); + } + cross (v1, v2, n); +} + + +static void normalise (vec3* v) +{ + float x = v->x; + float y = v->y; + float z = v->z; + float mag = sqrt (x*x + y*y + z*z); + mag = mag == 0.0f ? 1.0f : mag; + v->x /= mag; + v->y /= mag; + v->z /= mag; +} + + +static void vec3_add (vec3 a, vec3* b) +{ + b->x += a.x; + b->y += a.y; + b->z += a.z; +} + + +static void read_vertex (FILE* file, vec3* vert) +{ + fscanf (file, "%f %f", &vert->x, &vert->y); + if (fscanf(file, "%f", &vert->z) == 0) vert->z = 0.0f; +} + + +static void read_normal (FILE* file, vec3* normal) +{ + fscanf (file, "%f %f %f", &normal->x, &normal->y, &normal->z); +} + + +static void read_tex_coord (FILE* file, texCoord* texc) +{ + fscanf (file, "%f %f", &texc->s, &texc->t); +} + + +static void read_face (FILE* file, + char clockwise, + vector* vertices, + vector* normals, + vector* triangles) +{ + vector idxs; + vector texCoords; + + vector_new (&idxs, sizeof(int), 4); + vector_new (&texCoords, sizeof(int), 4); + + unsigned int index; + unsigned int normal; + unsigned int texc; + + fscanf (file, "f"); + + while (!feof(file) && fscanf(file, "%d", &index) > 0) + { + vector_append (&idxs, &index); + + if (fgetc (file) == '/') + { + fscanf (file, "%d", &texc); + vector_append (&texCoords, &texc); + } + else fseek (file, -1, SEEK_CUR); + + if (fgetc (file) == '/') + { + fscanf (file, "%d", &normal); + } + else fseek (file, -1, SEEK_CUR); + } + + // Triangulate the face and add its triangles to the triangles vector. + triangle tri; + tri.vertexIndices[0] = *((int*) vector_ith (&idxs, 0)) - 1; + tri.textureIndices[0] = *((int*) vector_ith (&texCoords, 0)) - 1; + + int i; + for (i = 1; i < vector_size(&idxs)-1; i++) + { + tri.vertexIndices[1] = *((int*) vector_ith (&idxs, i)) - 1; + tri.textureIndices[1] = *((int*) vector_ith (&texCoords, i)) - 1; + tri.vertexIndices[2] = *((int*) vector_ith (&idxs, i+1)) - 1; + tri.textureIndices[2] = *((int*) vector_ith (&texCoords, i+1)) - 1; + vector_append (triangles, &tri); + } + + // Compute face normal and add contribution to each of the face's vertices. + unsigned int i0 = tri.vertexIndices[0]; + unsigned int i1 = tri.vertexIndices[1]; + unsigned int i2 = tri.vertexIndices[2]; + + vec3 n; + vec3 v0 = *((vec3*) vector_ith (vertices, i0)); + vec3 v1 = *((vec3*) vector_ith (vertices, i1)); + vec3 v2 = *((vec3*) vector_ith (vertices, i2)); + compute_normal (clockwise, v0, v1, v2, &n); + + for (i = 0; i < vector_size (&idxs); i++) + { + int j = *((int*) vector_ith (&idxs, i)) - 1; + vec3* normal = (vec3*) vector_ith (normals, j); + vec3_add (n, normal); + } + + vector_free (&idxs); + vector_free (&texCoords); +} + + +Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model) +{ + vec3* norms = 0; + vec3* verts = 0; + texCoord* texcs = 0; + triangle* tris = 0; + + FILE* file = fopen (filename, "r"); + if (file == NULL) return Model_File_Not_Found; + + vec3 vert; + vec3 normal; + texCoord texc; + + vector vertices; + vector normals; + vector texCoords; + vector triangles; + + int result = vector_new (&vertices, sizeof(vec3), 0) + | vector_new (&normals, sizeof(vec3), 0) + | vector_new (&texCoords, sizeof(texCoord), 0) + | vector_new (&triangles, sizeof(triangle), 0); + + if (result != 0) + { + safe_free (vertices.data); + safe_free (normals.data); + safe_free (texCoords.data); + safe_free (triangles.data); + return Model_Memory_Allocation_Error; + } + + while (!feof(file)) + { + switch (fgetc(file)) + { + case 'v': + switch (fgetc(file)) + { + case 't': + read_tex_coord (file, &texc); + vector_append (&texCoords, &texc); + break; + + case 'n': + read_normal (file, &normal); + vector_append (&normals, &normal); + break; + + default: + read_vertex (file, &vert); + vector_append (&vertices, &vert); + break; + } + break; + + case 'f': + // Initialise the normals vector if it is empty. + if (vector_size(&normals) == 0) + { + vec3 zero; + zero.x = 0.0f; zero.y = 0.0f; zero.z = 0.0f; + vector_new (&normals, sizeof(vec3), vector_size(&vertices)); + vector_initialise (&normals, &zero); + } + read_face (file, clockwise, &vertices, &normals, &triangles); + break; + + case '#': + { + int x = 17; + while (x != '\n' && x != EOF) x = fgetc(file); + break; + } + + default: break; + } + } + + fclose (file); + + unsigned numVertices = vector_size (&vertices); + + // Normalise normals. + unsigned i; + for (i = 0; i < numVertices; ++i) + { + normalise (vector_ith (&normals, i)); + } + + model->vertices = (vec3*) vertices.data; + model->normals = (vec3*) normals.data; + model->texCoords = (texCoord*) texCoords.data; + model->triangles = (triangle*) triangles.data; + model->skins = 0; + model->animations = 0; + model->numFrames = 1; + model->numVertices = numVertices; + model->numTriangles = vector_size (&triangles); + model->numTexCoords = vector_size (&texCoords); + model->numSkins = 0; + model->numAnimations = 0; + + return Model_Success; +} 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 @@ -#ifndef _OBJ_LOAD_H -#define _OBJ_LOAD_H - -#include "../Model.h" -#include "../Model_error_code.h" - - -#ifdef __cplusplus -extern "C" { -#endif - -/// Loads the OBJ file specified by the given string. -/// 'clockwise' should be 1 if you plan to render the model in a clockwise environment, 0 otherwise. -/// 'smooth_normals' should be 1 if you want the loader to compute smooth normals, 0 otherwise. -Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model); - -/// Gets the last error generated by the OBJ loader. -char* get_last_error (); - -#ifdef __cplusplus -} -#endif - - -#endif // _OBJ_LOAD_H +#ifndef _OBJ_LOAD_H +#define _OBJ_LOAD_H + +#include "../Model.h" +#include "../Model_error_code.h" + + +#ifdef __cplusplus +extern "C" { +#endif + +/// Loads the OBJ file specified by the given string. +/// 'clockwise' should be 1 if you plan to render the model in a clockwise environment, 0 otherwise. +/// 'smooth_normals' should be 1 if you want the loader to compute smooth normals, 0 otherwise. +Model_error_code OBJ_load (const char* filename, char clockwise, char left_handed, Model* model); + +/// Gets the last error generated by the OBJ loader. +char* get_last_error (); + +#ifdef __cplusplus +} +#endif + + +#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 @@ -#include "cvector.h" -#include // malloc, realloc, free -#include // memcpy - - -int max (int a, int b) -{ - if (a > b) return a; - return b; -} - - -int vector_new (vector* v, int elem_size, int num_elems) -{ - int n = num_elems * elem_size; - - char* data = 0; - if (num_elems > 0) - { - data = (char*) malloc (n); - if (data == NULL) return 1; - } - - v->data = data; - v->next = data; - v->chunk_size = n; - v->elem_size = elem_size; - - return 0; -} - - -void vector_free (vector* v) -{ - if (v->data != 0) free (v->data); -} - - -void vector_initialise (vector* v, void* value) -{ - char* ptr = v->data; - int esize = v->elem_size; - int n = vector_size (v); - - int i; - for (i = 0; i < n; ++i) - { - memcpy (ptr, value, esize); - ptr += esize; - } -} - - -int vector_append (vector* v, void* elem) -{ - // Realloc a bigger chunk when the vector runs out of space. - if (v->next == v->data + v->chunk_size) - { - int old_chunk_size = v->chunk_size; - int n = max (v->elem_size, 2 * old_chunk_size); - - char* data = (char*) realloc (v->data, n); - if (data == NULL) return 1; - - v->data = data; - v->next = data + old_chunk_size; - v->chunk_size = n; - } - - memcpy ((void*)v->next, elem, v->elem_size); - v->next += v->elem_size; -} - - -void* vector_ith (vector* v, int i) -{ - return (void*) (v->data + i*v->elem_size); -} - - -int vector_size (vector* v) -{ - return (v->next - v->data) / v->elem_size; -} - - -int vector_capacity (vector* v) -{ - return v->chunk_size / v->elem_size; -} +#include "cvector.h" +#include // malloc, realloc, free +#include // memcpy + + +int max (int a, int b) +{ + if (a > b) return a; + return b; +} + + +int vector_new (vector* v, int elem_size, int num_elems) +{ + int n = num_elems * elem_size; + + char* data = 0; + if (num_elems > 0) + { + data = (char*) malloc (n); + if (data == NULL) return 1; + } + + v->data = data; + v->next = data; + v->chunk_size = n; + v->elem_size = elem_size; + + return 0; +} + + +void vector_free (vector* v) +{ + if (v->data != 0) free (v->data); +} + + +void vector_initialise (vector* v, void* value) +{ + char* ptr = v->data; + int esize = v->elem_size; + int n = vector_size (v); + + int i; + for (i = 0; i < n; ++i) + { + memcpy (ptr, value, esize); + ptr += esize; + } +} + + +int vector_append (vector* v, void* elem) +{ + // Realloc a bigger chunk when the vector runs out of space. + if (v->next == v->data + v->chunk_size) + { + int old_chunk_size = v->chunk_size; + int n = max (v->elem_size, 2 * old_chunk_size); + + char* data = (char*) realloc (v->data, n); + if (data == NULL) return 1; + + v->data = data; + v->next = data + old_chunk_size; + v->chunk_size = n; + } + + memcpy ((void*)v->next, elem, v->elem_size); + v->next += v->elem_size; +} + + +void* vector_ith (vector* v, int i) +{ + return (void*) (v->data + i*v->elem_size); +} + + +int vector_size (vector* v) +{ + return (v->next - v->data) / v->elem_size; +} + + +int vector_capacity (vector* v) +{ + return v->chunk_size / v->elem_size; +} 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 @@ -#ifndef _C_SPEAR_VECTOR_H -#define _C_SPEAR_VECTOR_H - -typedef struct -{ - char* data; - char* next; - int chunk_size; - int elem_size; -} -vector; - -/// Construct a new vector. -/// Returns non-zero on error. -int vector_new (vector* v, int elem_size, int num_elems); - -/// Free the vector. -void vector_free (vector* v); - -/// Initialise every position to the given value. -void vector_initialise (vector* v, void* value); - -/// Append an element. -/// Returns non-zero on error. -int vector_append (vector* v, void* elem); - -/// Access the ith element. -void* vector_ith (vector* v, int i); - -/// Return the number of elements in the vector. -int vector_size (vector* v); - -/// Return the vector's capacity. -int vector_capacity (vector* v); - -#endif // _C_SPEAR_VECTOR_H +#ifndef _C_SPEAR_VECTOR_H +#define _C_SPEAR_VECTOR_H + +typedef struct +{ + char* data; + char* next; + int chunk_size; + int elem_size; +} +vector; + +/// Construct a new vector. +/// Returns non-zero on error. +int vector_new (vector* v, int elem_size, int num_elems); + +/// Free the vector. +void vector_free (vector* v); + +/// Initialise every position to the given value. +void vector_initialise (vector* v, void* value); + +/// Append an element. +/// Returns non-zero on error. +int vector_append (vector* v, void* elem); + +/// Access the ith element. +void* vector_ith (vector* v, int i); + +/// Return the number of elements in the vector. +int vector_size (vector* v); + +/// Return the vector's capacity. +int vector_capacity (vector* v); + +#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 @@ -#ifndef _SPEAR_SYS_TYPES_H -#define _SPEAR_SYS_TYPES_H - -#include - -typedef int8_t I8; -typedef int16_t I16; -typedef int32_t I32; -typedef int64_t I64; -typedef uint8_t U8; -typedef uint16_t U16; -typedef uint32_t U32; -typedef uint64_t U64; - -#endif // _SPEAR_SYS_TYPES_H - +#ifndef _SPEAR_SYS_TYPES_H +#define _SPEAR_SYS_TYPES_H + +#include + +typedef int8_t I8; +typedef int16_t I16; +typedef int32_t I32; +typedef int64_t I64; +typedef uint8_t U8; +typedef uint16_t U16; +typedef uint32_t U32; +typedef uint64_t U64; + +#endif // _SPEAR_SYS_TYPES_H + 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 @@ -{-# LANGUAGE FlexibleInstances #-} -module Spear.GL -( - -- * Programs - GLSLProgram -, newProgram -, linkProgram -, useProgram -, unuseProgram -, withGLSLProgram - -- ** Locations -, attribLocation -, fragLocation -, uniformLocation - -- ** Uniforms -, Uniform(..) - -- * Shaders -, GLSLShader -, ShaderType(..) -, attachShader -, detachShader -, loadShader -, newShader - -- ** Source loading -, loadSource -, shaderSource -, readSource -, compile - -- * Helper functions -, ($=) -, Data.StateVar.get - -- * VAOs -, VAO -, newVAO -, bindVAO -, unbindVAO -, enableVAOAttrib -, attribVAOPointer - -- ** Rendering -, drawArrays -, drawElements - -- * Buffers -, GLBuffer -, TargetBuffer(..) -, BufferUsage(..) -, newBuffer -, bindBuffer -, unbindBuffer -, BufferData(..) -, bufferData' -, withGLBuffer - -- * Textures -, Texture -, SettableStateVar -, ($) - -- ** Creation and destruction -, newTexture -, loadTextureImage - -- ** Manipulation -, bindTexture -, unbindTexture -, loadTextureData -, texParami -, texParamf -, activeTexture - -- * Error Handling -, getGLError -, printGLError -, assertGL - -- * OpenGL -, module Graphics.Rendering.OpenGL.Raw.Core32 -, Ptr -, nullPtr -) -where - -import Spear.Assets.Image -import Spear.Game -import Spear.Math.Matrix3 (Matrix3) -import Spear.Math.Matrix4 (Matrix4) -import Spear.Math.Vector - -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Error -import Control.Monad.Trans.State as State -import qualified Data.ByteString.Char8 as B -import Data.StateVar -import Data.Word -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Utils as Foreign (with) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Array (withArray) -import Foreign.Storable (peek) -import Graphics.Rendering.OpenGL.Raw.Core32 -import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) -import System.IO (hPutStrLn, stderr) -import Unsafe.Coerce - --- --- MANAGEMENT --- - --- | A GLSL shader handle. -data GLSLShader = GLSLShader - { getShader :: GLuint - , getShaderKey :: Resource - } - -instance ResourceClass GLSLShader where - getResource = getShaderKey - --- | A GLSL program handle. -data GLSLProgram = GLSLProgram - { getProgram :: GLuint - , getProgramKey :: Resource - } - -instance ResourceClass GLSLProgram where - getResource = getProgramKey - --- | Supported shader types. -data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) - -toGLShader :: ShaderType -> GLenum -toGLShader VertexShader = gl_VERTEX_SHADER -toGLShader FragmentShader = gl_FRAGMENT_SHADER -toGLShader GeometryShader = gl_GEOMETRY_SHADER - --- | Apply the given function to the program's id. -withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a -withGLSLProgram prog f = f $ getProgram prog - --- | Get the location of the given uniform variable within the given program. -uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint -uniformLocation prog var = makeGettableStateVar $ - withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str) - --- | Get or set the location of the given variable to a fragment shader colour number. -fragLocation :: GLSLProgram -> String -> StateVar GLint -fragLocation prog var = makeStateVar get set - where - get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str) - set idx = withCString var $ \str -> - glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) - --- | Get or set the location of the given attribute within the given program. -attribLocation :: GLSLProgram -> String -> StateVar GLint -attribLocation prog var = makeStateVar get set - where - get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str) - set idx = withCString var $ \str -> - glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) - --- | Create a new program. -newProgram :: [GLSLShader] -> Game s GLSLProgram -newProgram shaders = do - h <- gameIO glCreateProgram - when (h == 0) $ gameError "glCreateProgram failed" - rkey <- register $ deleteProgram h - let program = GLSLProgram h rkey - mapM_ (gameIO . attachShader program) shaders - linkProgram program - return program - --- Delete the program. -deleteProgram :: GLuint -> IO () ---deleteProgram = glDeleteProgram -deleteProgram prog = do - putStrLn $ "Deleting shader program " ++ show prog - glDeleteProgram prog - --- | Link the program. -linkProgram :: GLSLProgram -> Game s () -linkProgram prog = do - let h = getProgram prog - err <- gameIO $ do - glLinkProgram h - alloca $ \statptr -> do - glGetProgramiv h gl_LINK_STATUS statptr - status <- peek statptr - case status of - 0 -> getStatus glGetProgramiv glGetProgramInfoLog h - _ -> return "" - - case length err of - 0 -> return () - _ -> gameError err - --- | Use the program. -useProgram :: GLSLProgram -> IO () -useProgram prog = glUseProgram $ getProgram prog - --- | Deactivate the active program. -unuseProgram :: IO () -unuseProgram = glUseProgram 0 - --- | Attach the given shader to the given program. -attachShader :: GLSLProgram -> GLSLShader -> IO () -attachShader prog shader = glAttachShader (getProgram prog) (getShader shader) - --- | Detach the given GLSL from the given program. -detachShader :: GLSLProgram -> GLSLShader -> IO () -detachShader prog shader = glDetachShader (getProgram prog) (getShader shader) - --- | Load a shader from the file specified by the given string. --- --- This function creates a new shader. To load source code into an existing shader, --- see 'loadSource', 'shaderSource' and 'readSource'. -loadShader :: ShaderType -> FilePath -> Game s GLSLShader -loadShader shaderType file = do - shader <- newShader shaderType - loadSource file shader - compile file shader - return shader - --- | Create a new shader. -newShader :: ShaderType -> Game s GLSLShader -newShader shaderType = do - h <- gameIO $ glCreateShader (toGLShader shaderType) - case h of - 0 -> gameError "glCreateShader failed" - _ -> do - rkey <- register $ deleteShader h - return $ GLSLShader h rkey - --- | Free the shader. -deleteShader :: GLuint -> IO () ---deleteShader = glDeleteShader -deleteShader shader = do - putStrLn $ "Deleting shader " ++ show shader - glDeleteShader shader - --- | Load a shader source from the file specified by the given string --- into the shader. -loadSource :: FilePath -> GLSLShader -> Game s () -loadSource file h = do - exists <- gameIO $ doesFileExist file - case exists of - False -> gameError "the specified shader file does not exist" - True -> gameIO $ do - code <- readSource file - withCString code $ shaderSource h - --- | Load the given shader source into the shader. -shaderSource :: GLSLShader -> CString -> IO () -shaderSource shader str = - let ptr = unsafeCoerce str - in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr - --- | Compile the shader. -compile :: FilePath -> GLSLShader -> Game s () -compile file shader = do - let h = getShader shader - - -- Compile - gameIO $ glCompileShader h - - -- Verify status - err <- gameIO $ alloca $ \statusPtr -> do - glGetShaderiv h gl_COMPILE_STATUS statusPtr - result <- peek statusPtr - case result of - 0 -> getStatus glGetShaderiv glGetShaderInfoLog h - _ -> return "" - - case length err of - 0 -> return () - _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err - -type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () -type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () - -getStatus :: StatusCall -> LogCall -> GLuint -> IO String -getStatus getStatus getLog h = do - alloca $ \lenPtr -> do - getStatus h gl_INFO_LOG_LENGTH lenPtr - len <- peek lenPtr - case len of - 0 -> return "" - _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len) - -getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String -getErrorString getLog h len str = do - let ptr = unsafeCoerce str - getLog h len nullPtr ptr - peekCString str - --- | Load the shader source specified by the given file. --- --- This function implements an #include mechanism, so the given file can --- refer to other files. -readSource :: FilePath -> IO String -readSource = fmap B.unpack . readSource' - -readSource' :: FilePath -> IO B.ByteString -readSource' file = do - let includeB = B.pack "#include" - newLineB = B.pack "\n" - isInclude = ((==) includeB) . B.take 8 - clean = B.dropWhile (\c -> c == ' ') - cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ') - toLines = B.splitWith (\c -> c == '\n' || c == '\r') - addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s - parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence . - fmap (processLine . clean) . toLines - processLine l = - if isInclude l - then readSource' $ B.unpack . clean . cleanInclude $ l - else return l - - contents <- B.readFile file - - dir <- getCurrentDirectory - let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file - - setCurrentDirectory dir' - code <- parse contents - setCurrentDirectory dir - - return code - -class Uniform a where - -- | Load a list of uniform values. - uniform :: GLint -> a -> IO () - -instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) -instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a) - -instance Uniform (Int,Int) where - uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y) - -instance Uniform (Float,Float) where - uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y) - -instance Uniform (Int,Int,Int) where - uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z) - -instance Uniform (Float,Float,Float) where - uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) - -instance Uniform (Int,Int,Int,Int) where - uniform loc (x,y,z,w) = glUniform4i loc - (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) - -instance Uniform (Float,Float,Float,Float) where - uniform loc (x,y,z,w) = glUniform4f loc - (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) (unsafeCoerce w) - -instance Uniform Vector2 where - uniform loc v = glUniform2f loc x' y' - where x' = unsafeCoerce $ x v - y' = unsafeCoerce $ y v - -instance Uniform Vector3 where - uniform loc v = glUniform3f loc x' y' z' - where x' = unsafeCoerce $ x v - y' = unsafeCoerce $ y v - z' = unsafeCoerce $ z v - -instance Uniform Vector4 where - uniform loc v = glUniform4f loc x' y' z' w' - where x' = unsafeCoerce $ x v - y' = unsafeCoerce $ y v - z' = unsafeCoerce $ z v - w' = unsafeCoerce $ w v - -instance Uniform Matrix3 where - uniform loc mat = - with mat $ \ptrMat -> - glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) - -instance Uniform Matrix4 where - uniform loc mat = - with mat $ \ptrMat -> - glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) - -instance Uniform [Float] where - uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr -> - case length vals of - 1 -> glUniform1fv loc 1 ptr - 2 -> glUniform2fv loc 1 ptr - 3 -> glUniform3fv loc 1 ptr - 4 -> glUniform4fv loc 1 ptr - -instance Uniform [Int] where - uniform loc vals = withArray (map fromIntegral vals) $ \ptr -> - case length vals of - 1 -> glUniform1iv loc 1 ptr - 2 -> glUniform2iv loc 1 ptr - 3 -> glUniform3iv loc 1 ptr - 4 -> glUniform4iv loc 1 ptr - --- --- VAOs --- - --- | A vertex array object. -data VAO = VAO - { getVAO :: GLuint - , vaoKey :: Resource - } - -instance ResourceClass VAO where - getResource = vaoKey - -instance Eq VAO where - vao1 == vao2 = getVAO vao1 == getVAO vao2 - -instance Ord VAO where - vao1 < vao2 = getVAO vao1 < getVAO vao2 - --- | Create a new vao. -newVAO :: Game s VAO -newVAO = do - h <- gameIO . alloca $ \ptr -> do - glGenVertexArrays 1 ptr - peek ptr - - rkey <- register $ deleteVAO h - return $ VAO h rkey - --- | Delete the vao. -deleteVAO :: GLuint -> IO () -deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 - --- | Bind the vao. -bindVAO :: VAO -> IO () -bindVAO = glBindVertexArray . getVAO - --- | Unbind the bound vao. -unbindVAO :: IO () -unbindVAO = glBindVertexArray 0 - --- | Enable the given vertex attribute of the bound vao. --- --- See also 'bindVAO'. -enableVAOAttrib :: GLuint -- ^ Attribute index. - -> IO () -enableVAOAttrib = glEnableVertexAttribArray - --- | Bind the bound buffer to the given point. -attribVAOPointer - :: GLuint -- ^ The index of the generic vertex attribute to be modified. - -> GLint -- ^ The number of components per generic vertex attribute. Must be 1,2,3,4. - -> GLenum -- ^ The data type of each component in the array. - -> Bool -- ^ Whether fixed-point data values should be normalized. - -> GLsizei -- ^ Stride. Byte offset between consecutive generic vertex attributes. - -> Int -- ^ Offset to the first component in the array. - -> IO () -attribVAOPointer idx ncomp dattype normalise stride off = - glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off) - where normalise' = if normalise then 1 else 0 - --- | Draw the bound vao. -drawArrays - :: GLenum -- ^ The kind of primitives to render. - -> Int -- ^ Starting index in the enabled arrays. - -> Int -- ^ The number of indices to be rendered. - -> IO () -drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) - --- | Draw the bound vao, indexed mode. -drawElements - :: GLenum -- ^ The kind of primitives to render. - -> Int -- ^ The number of elements to be rendered. - -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT. - -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer. - -> IO () -drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs - --- --- BUFFER --- - --- | An OpenGL buffer. -data GLBuffer = GLBuffer - { getBuffer :: GLuint - , rkey :: Resource - } - -instance ResourceClass GLBuffer where - getResource = rkey - --- | The type of target buffer. -data TargetBuffer - = ArrayBuffer - | ElementArrayBuffer - | PixelPackBuffer - | PixelUnpackBuffer - deriving (Eq, Show) - -fromTarget :: TargetBuffer -> GLenum -fromTarget ArrayBuffer = gl_ARRAY_BUFFER -fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER -fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER -fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER - --- | A buffer usage. -data BufferUsage - = StreamDraw - | StreamRead - | StreamCopy - | StaticDraw - | StaticRead - | StaticCopy - | DynamicDraw - | DynamicRead - | DynamicCopy - deriving (Eq, Show) - -fromUsage :: BufferUsage -> GLenum -fromUsage StreamDraw = gl_STREAM_DRAW -fromUsage StreamRead = gl_STREAM_READ -fromUsage StreamCopy = gl_STREAM_COPY -fromUsage StaticDraw = gl_STATIC_DRAW -fromUsage StaticRead = gl_STATIC_READ -fromUsage StaticCopy = gl_STATIC_COPY -fromUsage DynamicDraw = gl_DYNAMIC_DRAW -fromUsage DynamicRead = gl_DYNAMIC_READ -fromUsage DynamicCopy = gl_DYNAMIC_COPY - --- | Create a new buffer. -newBuffer :: Game s GLBuffer -newBuffer = do - h <- gameIO . alloca $ \ptr -> do - glGenBuffers 1 ptr - peek ptr - - rkey <- register $ deleteBuffer h - return $ GLBuffer h rkey - --- | Delete the buffer. -deleteBuffer :: GLuint -> IO () -deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 - --- | Bind the buffer. -bindBuffer :: GLBuffer -> TargetBuffer -> IO () -bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf - --- | Unbind the bound buffer. -unbindBuffer :: TargetBuffer -> IO () -unbindBuffer target = glBindBuffer (fromTarget target) 0 - -class Storable a => BufferData a where - -- | Set the buffer's data. - bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO () - bufferData tgt vals usage = - let n = sizeOf (head vals) * length vals - in withArray vals $ \ptr -> bufferData' tgt n ptr usage - -instance BufferData Word8 -instance BufferData Word16 -instance BufferData Word32 -instance BufferData CChar -instance BufferData CInt -instance BufferData CFloat -instance BufferData CDouble -instance BufferData Int -instance BufferData Float -instance BufferData Double - -{-bufferData :: Storable a - => TargetBuffer - -> Int -- ^ The size in bytes of an element in the data list. - -> [a] -- ^ The data list. - -> BufferUsage - -> IO () -bufferData target n bufData usage = withArray bufData $ - \ptr -> bufferData target (n * length bufData) ptr usage-} - --- | Set the buffer's data. -bufferData' :: TargetBuffer - -> Int -- ^ Buffer size in bytes. - -> Ptr a - -> BufferUsage - -> IO () -bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) - --- | Apply the given function the buffer's id. -withGLBuffer :: GLBuffer -> (GLuint -> a) -> a -withGLBuffer buf f = f $ getBuffer buf - --- --- TEXTURE --- - --- | Represents a texture resource. -data Texture = Texture - { getTex :: GLuint - , texKey :: Resource - } - -instance Eq Texture where - t1 == t2 = getTex t1 == getTex t2 - -instance Ord Texture where - t1 < t2 = getTex t1 < getTex t2 - -instance ResourceClass Texture where - getResource = texKey - --- | Create a new texture. -newTexture :: Game s Texture -newTexture = do - tex <- gameIO . alloca $ \ptr -> do - glGenTextures 1 ptr - peek ptr - - rkey <- register $ deleteTexture tex - return $ Texture tex rkey - --- | Delete the texture. -deleteTexture :: GLuint -> IO () ---deleteTexture tex = with tex $ glDeleteTextures 1 -deleteTexture tex = do - putStrLn $ "Releasing texture " ++ show tex - with tex $ glDeleteTextures 1 - --- | Load the 'Texture' specified by the given file. -loadTextureImage :: FilePath - -> GLenum -- ^ Texture's min filter. - -> GLenum -- ^ Texture's mag filter. - -> Game s Texture -loadTextureImage file minFilter magFilter = do - image <- loadImage file - tex <- newTexture - gameIO $ do - let w = width image - h = height image - pix = pixels image - rgb = fromIntegral . fromEnum $ gl_RGB - - bindTexture tex - loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix - texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter - texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter - - return tex - --- | Bind the texture. -bindTexture :: Texture -> IO () -bindTexture = glBindTexture gl_TEXTURE_2D . getTex - --- | Unbind the bound texture. -unbindTexture :: IO () -unbindTexture = glBindTexture gl_TEXTURE_2D 0 - --- | Load data onto the bound texture. --- --- See also 'bindTexture'. -loadTextureData :: GLenum - -> Int -- ^ Target - -> Int -- ^ Level - -> Int -- ^ Internal format - -> Int -- ^ Width - -> Int -- ^ Height - -> GLenum -- ^ Border - -> GLenum -- ^ Texture type - -> Ptr a -- ^ Texture data - -> IO () -loadTextureData target level internalFormat width height border format texType texData = do - glTexImage2D target - (fromIntegral level) - (fromIntegral internalFormat) - (fromIntegral width) - (fromIntegral height) - (fromIntegral border) - (fromIntegral format) - texType - texData - --- | Set the bound texture's parameter to the given value. -texParami :: GLenum -> GLenum -> SettableStateVar GLenum -texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val - --- | Set the bound texture's parameter to the given value. -texParamf :: GLenum -> GLenum -> SettableStateVar Float -texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) - --- | Set the active texture unit. -activeTexture :: SettableStateVar GLenum -activeTexture = makeSettableStateVar glActiveTexture - --- --- ERROR --- - --- | Get the last OpenGL error. -getGLError :: IO (Maybe String) -getGLError = fmap translate glGetError - where - translate err - | err == gl_NO_ERROR = Nothing - | err == gl_INVALID_ENUM = Just "Invalid enum" - | err == gl_INVALID_VALUE = Just "Invalid value" - | err == gl_INVALID_OPERATION = Just "Invalid operation" - | err == gl_OUT_OF_MEMORY = Just "Out of memory" - | otherwise = Just "Unknown error" - --- | Print the last OpenGL error. -printGLError :: IO () -printGLError = getGLError >>= \err -> case err of - Nothing -> return () - Just str -> hPutStrLn stderr str - --- | Run the given setup action and check for OpenGL errors. --- --- If an OpenGL error is produced, an exception is thrown containing --- the given string appended to the string describing the error. -assertGL :: Game s a -> String -> Game s a -assertGL action err = do - result <- action - status <- gameIO getGLError - case status of - Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str - Nothing -> return result +{-# LANGUAGE FlexibleInstances #-} +module Spear.GL +( + -- * Programs + GLSLProgram +, newProgram +, linkProgram +, useProgram +, unuseProgram +, withGLSLProgram + -- ** Locations +, attribLocation +, fragLocation +, uniformLocation + -- ** Uniforms +, Uniform(..) + -- * Shaders +, GLSLShader +, ShaderType(..) +, attachShader +, detachShader +, loadShader +, newShader + -- ** Source loading +, loadSource +, shaderSource +, readSource +, compile + -- * Helper functions +, ($=) +, Data.StateVar.get + -- * VAOs +, VAO +, newVAO +, bindVAO +, unbindVAO +, enableVAOAttrib +, attribVAOPointer + -- ** Rendering +, drawArrays +, drawElements + -- * Buffers +, GLBuffer +, TargetBuffer(..) +, BufferUsage(..) +, newBuffer +, bindBuffer +, unbindBuffer +, BufferData(..) +, bufferData' +, withGLBuffer + -- * Textures +, Texture +, SettableStateVar +, ($) + -- ** Creation and destruction +, newTexture +, loadTextureImage + -- ** Manipulation +, bindTexture +, unbindTexture +, loadTextureData +, texParami +, texParamf +, activeTexture + -- * Error Handling +, getGLError +, printGLError +, assertGL + -- * OpenGL +, module Graphics.Rendering.OpenGL.Raw.Core32 +, Ptr +, nullPtr +) +where + +import Spear.Assets.Image +import Spear.Game +import Spear.Math.Matrix3 (Matrix3) +import Spear.Math.Matrix4 (Matrix4) +import Spear.Math.Vector + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Error +import Control.Monad.Trans.State as State +import qualified Data.ByteString.Char8 as B +import Data.StateVar +import Data.Word +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Utils as Foreign (with) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (withArray) +import Foreign.Storable (peek) +import Graphics.Rendering.OpenGL.Raw.Core32 +import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) +import System.IO (hPutStrLn, stderr) +import Unsafe.Coerce + +-- +-- MANAGEMENT +-- + +-- | A GLSL shader handle. +data GLSLShader = GLSLShader + { getShader :: GLuint + , getShaderKey :: Resource + } + +instance ResourceClass GLSLShader where + getResource = getShaderKey + +-- | A GLSL program handle. +data GLSLProgram = GLSLProgram + { getProgram :: GLuint + , getProgramKey :: Resource + } + +instance ResourceClass GLSLProgram where + getResource = getProgramKey + +-- | Supported shader types. +data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) + +toGLShader :: ShaderType -> GLenum +toGLShader VertexShader = gl_VERTEX_SHADER +toGLShader FragmentShader = gl_FRAGMENT_SHADER +toGLShader GeometryShader = gl_GEOMETRY_SHADER + +-- | Apply the given function to the program's id. +withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a +withGLSLProgram prog f = f $ getProgram prog + +-- | Get the location of the given uniform variable within the given program. +uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint +uniformLocation prog var = makeGettableStateVar $ + withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str) + +-- | Get or set the location of the given variable to a fragment shader colour number. +fragLocation :: GLSLProgram -> String -> StateVar GLint +fragLocation prog var = makeStateVar get set + where + get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str) + set idx = withCString var $ \str -> + glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) + +-- | Get or set the location of the given attribute within the given program. +attribLocation :: GLSLProgram -> String -> StateVar GLint +attribLocation prog var = makeStateVar get set + where + get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str) + set idx = withCString var $ \str -> + glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) + +-- | Create a new program. +newProgram :: [GLSLShader] -> Game s GLSLProgram +newProgram shaders = do + h <- gameIO glCreateProgram + when (h == 0) $ gameError "glCreateProgram failed" + rkey <- register $ deleteProgram h + let program = GLSLProgram h rkey + mapM_ (gameIO . attachShader program) shaders + linkProgram program + return program + +-- Delete the program. +deleteProgram :: GLuint -> IO () +--deleteProgram = glDeleteProgram +deleteProgram prog = do + putStrLn $ "Deleting shader program " ++ show prog + glDeleteProgram prog + +-- | Link the program. +linkProgram :: GLSLProgram -> Game s () +linkProgram prog = do + let h = getProgram prog + err <- gameIO $ do + glLinkProgram h + alloca $ \statptr -> do + glGetProgramiv h gl_LINK_STATUS statptr + status <- peek statptr + case status of + 0 -> getStatus glGetProgramiv glGetProgramInfoLog h + _ -> return "" + + case length err of + 0 -> return () + _ -> gameError err + +-- | Use the program. +useProgram :: GLSLProgram -> IO () +useProgram prog = glUseProgram $ getProgram prog + +-- | Deactivate the active program. +unuseProgram :: IO () +unuseProgram = glUseProgram 0 + +-- | Attach the given shader to the given program. +attachShader :: GLSLProgram -> GLSLShader -> IO () +attachShader prog shader = glAttachShader (getProgram prog) (getShader shader) + +-- | Detach the given GLSL from the given program. +detachShader :: GLSLProgram -> GLSLShader -> IO () +detachShader prog shader = glDetachShader (getProgram prog) (getShader shader) + +-- | Load a shader from the file specified by the given string. +-- +-- This function creates a new shader. To load source code into an existing shader, +-- see 'loadSource', 'shaderSource' and 'readSource'. +loadShader :: ShaderType -> FilePath -> Game s GLSLShader +loadShader shaderType file = do + shader <- newShader shaderType + loadSource file shader + compile file shader + return shader + +-- | Create a new shader. +newShader :: ShaderType -> Game s GLSLShader +newShader shaderType = do + h <- gameIO $ glCreateShader (toGLShader shaderType) + case h of + 0 -> gameError "glCreateShader failed" + _ -> do + rkey <- register $ deleteShader h + return $ GLSLShader h rkey + +-- | Free the shader. +deleteShader :: GLuint -> IO () +--deleteShader = glDeleteShader +deleteShader shader = do + putStrLn $ "Deleting shader " ++ show shader + glDeleteShader shader + +-- | Load a shader source from the file specified by the given string +-- into the shader. +loadSource :: FilePath -> GLSLShader -> Game s () +loadSource file h = do + exists <- gameIO $ doesFileExist file + case exists of + False -> gameError "the specified shader file does not exist" + True -> gameIO $ do + code <- readSource file + withCString code $ shaderSource h + +-- | Load the given shader source into the shader. +shaderSource :: GLSLShader -> CString -> IO () +shaderSource shader str = + let ptr = unsafeCoerce str + in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr + +-- | Compile the shader. +compile :: FilePath -> GLSLShader -> Game s () +compile file shader = do + let h = getShader shader + + -- Compile + gameIO $ glCompileShader h + + -- Verify status + err <- gameIO $ alloca $ \statusPtr -> do + glGetShaderiv h gl_COMPILE_STATUS statusPtr + result <- peek statusPtr + case result of + 0 -> getStatus glGetShaderiv glGetShaderInfoLog h + _ -> return "" + + case length err of + 0 -> return () + _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err + +type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () +type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () + +getStatus :: StatusCall -> LogCall -> GLuint -> IO String +getStatus getStatus getLog h = do + alloca $ \lenPtr -> do + getStatus h gl_INFO_LOG_LENGTH lenPtr + len <- peek lenPtr + case len of + 0 -> return "" + _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len) + +getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String +getErrorString getLog h len str = do + let ptr = unsafeCoerce str + getLog h len nullPtr ptr + peekCString str + +-- | Load the shader source specified by the given file. +-- +-- This function implements an #include mechanism, so the given file can +-- refer to other files. +readSource :: FilePath -> IO String +readSource = fmap B.unpack . readSource' + +readSource' :: FilePath -> IO B.ByteString +readSource' file = do + let includeB = B.pack "#include" + newLineB = B.pack "\n" + isInclude = ((==) includeB) . B.take 8 + clean = B.dropWhile (\c -> c == ' ') + cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ') + toLines = B.splitWith (\c -> c == '\n' || c == '\r') + addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s + parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence . + fmap (processLine . clean) . toLines + processLine l = + if isInclude l + then readSource' $ B.unpack . clean . cleanInclude $ l + else return l + + contents <- B.readFile file + + dir <- getCurrentDirectory + let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file + + setCurrentDirectory dir' + code <- parse contents + setCurrentDirectory dir + + return code + +class Uniform a where + -- | Load a list of uniform values. + uniform :: GLint -> a -> IO () + +instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) +instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a) +instance Uniform CFloat where uniform loc a = glUniform1f loc a + +instance Uniform (Int,Int) where + uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y) + +instance Uniform (Float,Float) where + uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y) + +instance Uniform (Int,Int,Int) where + uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z) + +instance Uniform (Float,Float,Float) where + uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) + +instance Uniform (Int,Int,Int,Int) where + uniform loc (x,y,z,w) = glUniform4i loc + (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) + +instance Uniform (Float,Float,Float,Float) where + uniform loc (x,y,z,w) = glUniform4f loc + (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) (unsafeCoerce w) + +instance Uniform Vector2 where + uniform loc v = glUniform2f loc x' y' + where x' = unsafeCoerce $ x v + y' = unsafeCoerce $ y v + +instance Uniform Vector3 where + uniform loc v = glUniform3f loc x' y' z' + where x' = unsafeCoerce $ x v + y' = unsafeCoerce $ y v + z' = unsafeCoerce $ z v + +instance Uniform Vector4 where + uniform loc v = glUniform4f loc x' y' z' w' + where x' = unsafeCoerce $ x v + y' = unsafeCoerce $ y v + z' = unsafeCoerce $ z v + w' = unsafeCoerce $ w v + +instance Uniform Matrix3 where + uniform loc mat = + with mat $ \ptrMat -> + glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) + +instance Uniform Matrix4 where + uniform loc mat = + with mat $ \ptrMat -> + glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) + +instance Uniform [Float] where + uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr -> + case length vals of + 1 -> glUniform1fv loc 1 ptr + 2 -> glUniform2fv loc 1 ptr + 3 -> glUniform3fv loc 1 ptr + 4 -> glUniform4fv loc 1 ptr + +instance Uniform [CFloat] where + uniform loc vals = withArray vals $ \ptr -> + case length vals of + 1 -> glUniform1fv loc 1 ptr + 2 -> glUniform2fv loc 1 ptr + 3 -> glUniform3fv loc 1 ptr + 4 -> glUniform4fv loc 1 ptr + +instance Uniform [Int] where + uniform loc vals = withArray (map fromIntegral vals) $ \ptr -> + case length vals of + 1 -> glUniform1iv loc 1 ptr + 2 -> glUniform2iv loc 1 ptr + 3 -> glUniform3iv loc 1 ptr + 4 -> glUniform4iv loc 1 ptr + +-- +-- VAOs +-- + +-- | A vertex array object. +data VAO = VAO + { getVAO :: GLuint + , vaoKey :: Resource + } + +instance ResourceClass VAO where + getResource = vaoKey + +instance Eq VAO where + vao1 == vao2 = getVAO vao1 == getVAO vao2 + +instance Ord VAO where + vao1 < vao2 = getVAO vao1 < getVAO vao2 + +-- | Create a new vao. +newVAO :: Game s VAO +newVAO = do + h <- gameIO . alloca $ \ptr -> do + glGenVertexArrays 1 ptr + peek ptr + + rkey <- register $ deleteVAO h + return $ VAO h rkey + +-- | Delete the vao. +deleteVAO :: GLuint -> IO () +deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 + +-- | Bind the vao. +bindVAO :: VAO -> IO () +bindVAO = glBindVertexArray . getVAO + +-- | Unbind the bound vao. +unbindVAO :: IO () +unbindVAO = glBindVertexArray 0 + +-- | Enable the given vertex attribute of the bound vao. +-- +-- See also 'bindVAO'. +enableVAOAttrib :: GLuint -- ^ Attribute index. + -> IO () +enableVAOAttrib = glEnableVertexAttribArray + +-- | Bind the bound buffer to the given point. +attribVAOPointer + :: GLuint -- ^ The index of the generic vertex attribute to be modified. + -> GLint -- ^ The number of components per generic vertex attribute. Must be 1,2,3,4. + -> GLenum -- ^ The data type of each component in the array. + -> Bool -- ^ Whether fixed-point data values should be normalized. + -> GLsizei -- ^ Stride. Byte offset between consecutive generic vertex attributes. + -> Int -- ^ Offset to the first component in the array. + -> IO () +attribVAOPointer idx ncomp dattype normalise stride off = + glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off) + where normalise' = if normalise then 1 else 0 + +-- | Draw the bound vao. +drawArrays + :: GLenum -- ^ The kind of primitives to render. + -> Int -- ^ Starting index in the enabled arrays. + -> Int -- ^ The number of indices to be rendered. + -> IO () +drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) + +-- | Draw the bound vao, indexed mode. +drawElements + :: GLenum -- ^ The kind of primitives to render. + -> Int -- ^ The number of elements to be rendered. + -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT. + -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer. + -> IO () +drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs + +-- +-- BUFFER +-- + +-- | An OpenGL buffer. +data GLBuffer = GLBuffer + { getBuffer :: GLuint + , rkey :: Resource + } + +instance ResourceClass GLBuffer where + getResource = rkey + +-- | The type of target buffer. +data TargetBuffer + = ArrayBuffer + | ElementArrayBuffer + | PixelPackBuffer + | PixelUnpackBuffer + deriving (Eq, Show) + +fromTarget :: TargetBuffer -> GLenum +fromTarget ArrayBuffer = gl_ARRAY_BUFFER +fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER +fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER +fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER + +-- | A buffer usage. +data BufferUsage + = StreamDraw + | StreamRead + | StreamCopy + | StaticDraw + | StaticRead + | StaticCopy + | DynamicDraw + | DynamicRead + | DynamicCopy + deriving (Eq, Show) + +fromUsage :: BufferUsage -> GLenum +fromUsage StreamDraw = gl_STREAM_DRAW +fromUsage StreamRead = gl_STREAM_READ +fromUsage StreamCopy = gl_STREAM_COPY +fromUsage StaticDraw = gl_STATIC_DRAW +fromUsage StaticRead = gl_STATIC_READ +fromUsage StaticCopy = gl_STATIC_COPY +fromUsage DynamicDraw = gl_DYNAMIC_DRAW +fromUsage DynamicRead = gl_DYNAMIC_READ +fromUsage DynamicCopy = gl_DYNAMIC_COPY + +-- | Create a new buffer. +newBuffer :: Game s GLBuffer +newBuffer = do + h <- gameIO . alloca $ \ptr -> do + glGenBuffers 1 ptr + peek ptr + + rkey <- register $ deleteBuffer h + return $ GLBuffer h rkey + +-- | Delete the buffer. +deleteBuffer :: GLuint -> IO () +deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 + +-- | Bind the buffer. +bindBuffer :: TargetBuffer -> GLBuffer -> IO () +bindBuffer target buf = glBindBuffer (fromTarget target) $ getBuffer buf + +-- | Unbind the bound buffer. +unbindBuffer :: TargetBuffer -> IO () +unbindBuffer target = glBindBuffer (fromTarget target) 0 + +class Storable a => BufferData a where + -- | Set the buffer's data. + bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO () + bufferData tgt vals usage = + let n = sizeOf (head vals) * length vals + in withArray vals $ \ptr -> bufferData' tgt n ptr usage + +instance BufferData Word8 +instance BufferData Word16 +instance BufferData Word32 +instance BufferData CChar +instance BufferData CInt +instance BufferData CFloat +instance BufferData CDouble +instance BufferData Int +instance BufferData Float +instance BufferData Double + +{-bufferData :: Storable a + => TargetBuffer + -> Int -- ^ The size in bytes of an element in the data list. + -> [a] -- ^ The data list. + -> BufferUsage + -> IO () +bufferData target n bufData usage = withArray bufData $ + \ptr -> bufferData target (n * length bufData) ptr usage-} + +-- | Set the buffer's data. +bufferData' :: TargetBuffer + -> Int -- ^ Buffer size in bytes. + -> Ptr a + -> BufferUsage + -> IO () +bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) + +-- | Apply the given function the buffer's id. +withGLBuffer :: GLBuffer -> (GLuint -> a) -> a +withGLBuffer buf f = f $ getBuffer buf + +-- +-- TEXTURE +-- + +-- | Represents a texture resource. +data Texture = Texture + { getTex :: GLuint + , texKey :: Resource + } + +instance Eq Texture where + t1 == t2 = getTex t1 == getTex t2 + +instance Ord Texture where + t1 < t2 = getTex t1 < getTex t2 + +instance ResourceClass Texture where + getResource = texKey + +-- | Create a new texture. +newTexture :: Game s Texture +newTexture = do + tex <- gameIO . alloca $ \ptr -> do + glGenTextures 1 ptr + peek ptr + + rkey <- register $ deleteTexture tex + return $ Texture tex rkey + +-- | Delete the texture. +deleteTexture :: GLuint -> IO () +--deleteTexture tex = with tex $ glDeleteTextures 1 +deleteTexture tex = do + putStrLn $ "Releasing texture " ++ show tex + with tex $ glDeleteTextures 1 + +-- | Load the 'Texture' specified by the given file. +loadTextureImage :: FilePath + -> GLenum -- ^ Texture's min filter. + -> GLenum -- ^ Texture's mag filter. + -> Game s Texture +loadTextureImage file minFilter magFilter = do + image <- loadImage file + tex <- newTexture + gameIO $ do + let w = width image + h = height image + pix = pixels image + rgb = fromIntegral . fromEnum $ gl_RGB + + bindTexture tex + loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix + texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter + texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter + + return tex + +-- | Bind the texture. +bindTexture :: Texture -> IO () +bindTexture = glBindTexture gl_TEXTURE_2D . getTex + +-- | Unbind the bound texture. +unbindTexture :: IO () +unbindTexture = glBindTexture gl_TEXTURE_2D 0 + +-- | Load data onto the bound texture. +-- +-- See also 'bindTexture'. +loadTextureData :: GLenum + -> Int -- ^ Target + -> Int -- ^ Level + -> Int -- ^ Internal format + -> Int -- ^ Width + -> Int -- ^ Height + -> GLenum -- ^ Border + -> GLenum -- ^ Texture type + -> Ptr a -- ^ Texture data + -> IO () +loadTextureData target level internalFormat width height border format texType texData = do + glTexImage2D target + (fromIntegral level) + (fromIntegral internalFormat) + (fromIntegral width) + (fromIntegral height) + (fromIntegral border) + (fromIntegral format) + texType + texData + +-- | Set the bound texture's parameter to the given value. +texParami :: GLenum -> GLenum -> SettableStateVar GLenum +texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val + +-- | Set the bound texture's parameter to the given value. +texParamf :: GLenum -> GLenum -> SettableStateVar Float +texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) + +-- | Set the active texture unit. +activeTexture :: SettableStateVar GLenum +activeTexture = makeSettableStateVar glActiveTexture + +-- +-- ERROR +-- + +-- | Get the last OpenGL error. +getGLError :: IO (Maybe String) +getGLError = fmap translate glGetError + where + translate err + | err == gl_NO_ERROR = Nothing + | err == gl_INVALID_ENUM = Just "Invalid enum" + | err == gl_INVALID_VALUE = Just "Invalid value" + | err == gl_INVALID_OPERATION = Just "Invalid operation" + | err == gl_OUT_OF_MEMORY = Just "Out of memory" + | otherwise = Just "Unknown error" + +-- | Print the last OpenGL error. +printGLError :: IO () +printGLError = getGLError >>= \err -> case err of + Nothing -> return () + Just str -> hPutStrLn stderr str + +-- | Run the given setup action and check for OpenGL errors. +-- +-- If an OpenGL error is produced, an exception is thrown containing +-- the given string appended to the string describing the error. +assertGL :: Game s a -> String -> Game s a +assertGL action err = do + result <- action + status <- gameIO getGLError + case status of + Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str + 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 @@ -module Spear.Game -( - Game -, Resource -, ResourceClass(..) - -- * Game State -, getGameState -, saveGameState -, modifyGameState - -- * Game Resources -, register -, unregister -, gameError -, assertMaybe - -- * Running and IO -, runGame -, runGame' -, runSubGame -, runSubGame' -, evalSubGame -, execSubGame -, gameIO -) -where - -import Control.Monad.Trans.Class (lift) -import Control.Monad.State.Strict -import Control.Monad.Error -import qualified Control.Monad.Trans.Resource as R - -type Resource = R.ReleaseKey -type Game s = StateT s (R.ResourceT (ErrorT String IO)) - -class ResourceClass a where - getResource :: a -> Resource - - release :: a -> Game s () - release = unregister . getResource - - clean :: a -> IO () - clean = R.release . getResource - --- | Retrieve the game state. -getGameState :: Game s s -getGameState = get - --- | Save the game state. -saveGameState :: s -> Game s () -saveGameState = put - --- | Modify the game state. -modifyGameState :: (s -> s) -> Game s () -modifyGameState = modify - --- | Register the given cleaner. -register :: IO () -> Game s Resource -register = lift . R.register - --- | Release the given 'Resource'. -unregister :: Resource -> Game s () -unregister = lift . R.release - --- | Throw an error from the 'Game' monad. -gameError :: String -> Game s a -gameError = lift . lift . throwError - --- | Throw the given error string if given 'Nothing'. -assertMaybe :: Maybe a -> String -> Game s a -assertMaybe Nothing err = gameError err -assertMaybe (Just x) _ = return x - --- | Run the given game. -runGame :: Game s a -> s -> IO (Either String (a,s)) -runGame game state = runErrorT . R.runResourceT . runStateT game $ state - --- | Run the given game. -runGame' :: Game s a -> s -> IO () -runGame' game state = runGame game state >> return () - --- | Run the given game. -runSubGame :: Game s a -> s -> Game t (a,s) -runSubGame game state = lift $ runStateT game state - --- | Run the given game. -runSubGame' :: Game s a -> s -> Game t () -runSubGame' game state = runSubGame game state >> return () - --- | Run the given game and return its result. -evalSubGame :: Game s a -> s -> Game t a -evalSubGame g s = lift $ evalStateT g s - --- | Run the given game and return its state. -execSubGame :: Game s a -> s -> Game t s -execSubGame g s = lift $ execStateT g s - --- | Perform the given IO action in the 'Game' monad. -gameIO :: IO a -> Game s a -gameIO = lift . lift . lift +module Spear.Game +( + Game +, Resource +, ResourceClass(..) + -- * Game state +, getGameState +, saveGameState +, modifyGameState + -- * Game resources +, register +, unregister + -- * Error handling +, gameError +, assertMaybe +, catchGameError +, catchGameErrorFinally + -- * Running and IO +, runGame +, runSubGame +, evalSubGame +, execSubGame +, gameIO +) +where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.State.Strict +import Control.Monad.Error +import qualified Control.Monad.Trans.Resource as R + +type Resource = R.ReleaseKey +type Game s = StateT s (R.ResourceT (ErrorT String IO)) + +class ResourceClass a where + getResource :: a -> Resource + + release :: a -> Game s () + release = unregister . getResource + + clean :: a -> IO () + clean = R.release . getResource + +-- | Retrieve the game state. +getGameState :: Game s s +getGameState = get + +-- | Save the game state. +saveGameState :: s -> Game s () +saveGameState = put + +-- | Modify the game state. +modifyGameState :: (s -> s) -> Game s () +modifyGameState = modify + +-- | Register the given cleaner. +register :: IO () -> Game s Resource +register = lift . R.register + +-- | Release the given 'Resource'. +unregister :: Resource -> Game s () +unregister = lift . R.release + +-- | Throw an error from the 'Game' monad. +gameError :: String -> Game s a +gameError = lift . lift . throwError + +-- | Throw the given error string if given 'Nothing'. +assertMaybe :: Maybe a -> String -> Game s a +assertMaybe Nothing err = gameError err +assertMaybe (Just x) _ = return x + +-- | Run the given game with the given error handler. +catchGameError :: Game s a -> (String -> Game s a) -> Game s a +catchGameError game catch = catchError game catch + +-- | Run the given game, catch any error, run the given finaliser and rethrow the error. +catchGameErrorFinally :: Game s a -> Game s a -> Game s a +catchGameErrorFinally game finally = catchError game $ \err -> finally >> gameError err + +-- | Run the given game. +runGame :: Game s a -> s -> IO (Either String (a,s)) +runGame game state = runErrorT . R.runResourceT . runStateT game $ state + +-- | Fully run the given sub game, unrolling the entire monad stack. +runSubGame :: Game s a -> s -> Game t (a,s) +runSubGame game state = gameIO (runGame game state) >>= \result -> case result of + Left err -> gameError err + Right x -> return x + +-- | Run the given game and return its result. +evalSubGame :: Game s a -> s -> Game t a +evalSubGame g s = runSubGame g s >>= \(a,_) -> return a + +-- | Run the given game and return its state. +execSubGame :: Game s a -> s -> Game t s +execSubGame g s = runSubGame g s >>= \(_,s) -> return s + +-- | Perform the given IO action in the 'Game' monad. +gameIO :: IO a -> Game s a +gameIO = lift . lift . lift diff --git a/Spear/Math/AABB.hs b/Spear/Math/AABB.hs index 681f194..068a619 100644 --- a/Spear/Math/AABB.hs +++ b/Spear/Math/AABB.hs @@ -1,40 +1,40 @@ -module Spear.Math.AABB -( - AABB2(..) -, AABB3(..) -, aabb2 -, aabb3 -, aabb2pt -, aabb3pt -) -where - -import Spear.Math.Vector - -import Data.List (foldl') - --- | An axis-aligned bounding box in 2D space. -data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 - --- | An axis-aligned bounding box in 3D space. -data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 - --- | Create a AABB from the given points. -aabb2 :: [Vector2] -> AABB2 -aabb2 [] = AABB2 zero2 zero2 -aabb2 (x:xs) = foldl' update (AABB2 x x) xs - where update (AABB2 pmin pmax) p = AABB2 (min p pmin) (max p pmax) - --- | Create an AABB from the given points. -aabb3 :: [Vector3] -> AABB3 -aabb3 [] = AABB3 zero3 zero3 -aabb3 (x:xs) = foldl' update (AABB3 x x) xs - where update (AABB3 pmin pmax) p = AABB3 (min p pmin) (max p pmax) - --- | Return 'True' if the given AABB contains the given point, 'False' otherwise. -aabb2pt :: AABB2 -> Vector2 -> Bool -aabb2pt (AABB2 pmin pmax) v = v >= pmin && v <= pmax - --- | Return 'True' if the given AABB contains the given point, 'False' otherwise. -aabb3pt :: AABB3 -> Vector3 -> Bool -aabb3pt (AABB3 pmin pmax) v = v >= pmin && v <= pmax +module Spear.Math.AABB +( + AABB2(..) +, AABB3(..) +, aabb2 +, aabb3 +, aabb2pt +, aabb3pt +) +where + +import Spear.Math.Vector + +import Data.List (foldl') + +-- | An axis-aligned bounding box in 2D space. +data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 + +-- | An axis-aligned bounding box in 3D space. +data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 + +-- | Create a AABB from the given points. +aabb2 :: [Vector2] -> AABB2 +aabb2 [] = AABB2 zero2 zero2 +aabb2 (x:xs) = foldl' update (AABB2 x x) xs + where update (AABB2 pmin pmax) p = AABB2 (min p pmin) (max p pmax) + +-- | Create an AABB from the given points. +aabb3 :: [Vector3] -> AABB3 +aabb3 [] = AABB3 zero3 zero3 +aabb3 (x:xs) = foldl' update (AABB3 x x) xs + where update (AABB3 pmin pmax) p = AABB3 (min p pmin) (max p pmax) + +-- | Return 'True' if the given AABB contains the given point, 'False' otherwise. +aabb2pt :: AABB2 -> Vector2 -> Bool +aabb2pt (AABB2 pmin pmax) v = v >= pmin && v <= pmax + +-- | Return 'True' if the given AABB contains the given point, 'False' otherwise. +aabb3pt :: AABB3 -> Vector3 -> Bool +aabb3pt (AABB3 pmin pmax) v = v >= pmin && v <= pmax diff --git a/Spear/Math/Camera.hs b/Spear/Math/Camera.hs index e7062ab..220c435 100644 --- a/Spear/Math/Camera.hs +++ b/Spear/Math/Camera.hs @@ -1,75 +1,75 @@ -module Spear.Math.Camera -( - Camera -, Fovy -, Aspect -, Near -, Far -, Left -, Right -, Bottom -, Top -, projection -, perspective -, ortho -) -where - -import qualified Spear.Math.Matrix4 as M -import Spear.Math.Spatial3 -import Spear.Math.Vector - -data Camera = Camera - { projection :: M.Matrix4 -- ^ Get the camera's projection. - , spatial :: Obj3 - } - -instance Spatial3 Camera where - getObj3 = spatial - setObj3 cam o = cam { spatial = o } - -type Fovy = Float -type Aspect = Float -type Near = Float -type Far = Float -type Left = Float -type Right = Float -type Bottom = Float -type Top = Float - --- | Build a perspective camera. -perspective :: Fovy -- ^ Fovy - Vertical field of view angle in degrees. - -> Aspect -- ^ Aspect ratio. - -> Near -- ^ Near clip. - -> Far -- ^ Far clip. - -> Right3 -- ^ Right vector. - -> Up3 -- ^ Up vector. - -> Forward3 -- ^ Forward vector. - -> Position3 -- ^ Position vector. - -> Camera - -perspective fovy r n f right up fwd pos = - Camera - { projection = M.perspective fovy r n f - , spatial = fromVectors right up fwd pos - } - - --- | Build an orthogonal camera. -ortho :: Left -- ^ Left. - -> Right -- ^ Right. - -> Bottom -- ^ Bottom. - -> Top -- ^ Top. - -> Near -- ^ Near clip. - -> Far -- ^ Far clip. - -> Right3 -- ^ Right vector. - -> Up3 -- ^ Up vector. - -> Forward3 -- ^ Forward vector. - -> Position3 -- ^ Position vector. - -> Camera - -ortho l r b t n f right up fwd pos = - Camera - { projection = M.ortho l r b t n f - , spatial = fromVectors right up fwd pos - } +module Spear.Math.Camera +( + Camera +, Fovy +, Aspect +, Near +, Far +, Left +, Right +, Bottom +, Top +, projection +, perspective +, ortho +) +where + +import qualified Spear.Math.Matrix4 as M +import Spear.Math.Spatial3 +import Spear.Math.Vector + +data Camera = Camera + { projection :: M.Matrix4 -- ^ Get the camera's projection. + , spatial :: Obj3 + } + +instance Spatial3 Camera where + getObj3 = spatial + setObj3 cam o = cam { spatial = o } + +type Fovy = Float +type Aspect = Float +type Near = Float +type Far = Float +type Left = Float +type Right = Float +type Bottom = Float +type Top = Float + +-- | Build a perspective camera. +perspective :: Fovy -- ^ Fovy - Vertical field of view angle in degrees. + -> Aspect -- ^ Aspect ratio. + -> Near -- ^ Near clip. + -> Far -- ^ Far clip. + -> Right3 -- ^ Right vector. + -> Up3 -- ^ Up vector. + -> Forward3 -- ^ Forward vector. + -> Position3 -- ^ Position vector. + -> Camera + +perspective fovy r n f right up fwd pos = + Camera + { projection = M.perspective fovy r n f + , spatial = fromVectors right up fwd pos + } + + +-- | Build an orthogonal camera. +ortho :: Left -- ^ Left. + -> Right -- ^ Right. + -> Bottom -- ^ Bottom. + -> Top -- ^ Top. + -> Near -- ^ Near clip. + -> Far -- ^ Far clip. + -> Right3 -- ^ Right vector. + -> Up3 -- ^ Up vector. + -> Forward3 -- ^ Forward vector. + -> Position3 -- ^ Position vector. + -> Camera + +ortho l r b t n f right up fwd pos = + Camera + { projection = M.ortho l r b t n f + , spatial = fromVectors right up fwd pos + } 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 @@ -module Spear.Math.Circle -where - -import Spear.Math.Vector - -import Data.List (foldl') - --- | A circle in 2D space. -data Circle = Circle - { center :: {-# UNPACK #-} !Vector2 - , radius :: {-# UNPACK #-} !Float - } - --- | Create a circle from the given points. -circle :: [Vector2] -> Circle -circle [] = Circle zero2 0 -circle (x:xs) = Circle c r - where - c = pmin + (pmax-pmin)/2 - r = norm $ pmax - c - (pmin,pmax) = foldl' update (x,x) xs - update (pmin,pmax) p = (min p pmin, max p pmax) - --- | Return 'True' if the given circle contains the given point, 'False' otherwise. -circlept :: Circle -> Vector2 -> Bool -circlept (Circle c r) p = r*r >= normSq (p - c) +module Spear.Math.Circle +where + +import Spear.Math.Vector + +import Data.List (foldl') + +-- | A circle in 2D space. +data Circle = Circle + { center :: {-# UNPACK #-} !Vector2 + , radius :: {-# UNPACK #-} !Float + } + +-- | Create a circle from the given points. +circle :: [Vector2] -> Circle +circle [] = Circle zero2 0 +circle (x:xs) = Circle c r + where + c = pmin + (pmax-pmin)/2 + r = norm $ pmax - c + (pmin,pmax) = foldl' update (x,x) xs + update (pmin,pmax) p = (min p pmin, max p pmax) + +-- | Return 'True' if the given circle contains the given point, 'False' otherwise. +circlept :: Circle -> Vector2 -> Bool +circlept (Circle c r) p = r*r >= normSq (p - c) diff --git a/Spear/Math/Collision.hs b/Spear/Math/Collision.hs index 47cc5fd..a69ea7a 100644 --- a/Spear/Math/Collision.hs +++ b/Spear/Math/Collision.hs @@ -1,242 +1,242 @@ -module Spear.Math.Collision -( - CollisionType(..) - -- * 2D Collision -, Collisionable2(..) -, Collisioner2(..) - -- ** Construction -, aabb2Collisioner -, circleCollisioner -, mkCols - -- ** Collision test -, collide - -- ** Manipulation -, move - -- ** Helpers -, buildAABB2 -, aabb2FromCircle -, circleFromAABB2 - -- * 3D Collision -, Collisionable3(..) - -- ** Helpers -, aabb3FromSphere -) -where - -import Spear.Assets.Model -import Spear.Math.AABB -import Spear.Math.Circle -import qualified Spear.Math.Matrix4 as M4 -import Spear.Math.Plane -import Spear.Math.Sphere -import Spear.Math.Vector - -import Data.List (foldl') - -data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy - deriving (Eq, Show) - --- 2D collision - -class Collisionable2 a where - - -- | Collide the object with an AABB. - collideAABB2 :: AABB2 -> a -> CollisionType - - -- | Collide the object with a circle. - collideCircle :: Circle -> a -> CollisionType - -instance Collisionable2 AABB2 where - - collideAABB2 box1@(AABB2 min1 max1) box2@(AABB2 min2 max2) - | (x max1) < (x min2) = NoCollision - | (x min1) > (x max2) = NoCollision - | (y max1) < (y min2) = NoCollision - | (y min1) > (y max2) = NoCollision - | box1 `aabb2pt` min2 && box1 `aabb2pt` max2 = FullyContains - | box2 `aabb2pt` min1 && box2 `aabb2pt` max1 = FullyContainedBy - | otherwise = Collision - - collideCircle circle@(Circle c r) aabb@(AABB2 min max) - | test == FullyContains || test == FullyContainedBy = test - | normSq (c - boxC) > (l + r)^2 = NoCollision - | otherwise = Collision - where - test = collideAABB2 aabb $ aabb2FromCircle circle - boxC = min + (max-min)/2 - l = norm $ min + (vec2 (x boxC) (y min)) - min - -instance Collisionable2 Circle where - - collideAABB2 box circle = case collideCircle circle box of - FullyContains -> FullyContainedBy - FullyContainedBy -> FullyContains - x -> x - - collideCircle s1@(Circle c1 r1) s2@(Circle c2 r2) - | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy - | distance_centers <= sum_radii = Collision - | otherwise = NoCollision - where - distance_centers = normSq $ c1 - c2 - sum_radii = (r1 + r2)^2 - sub_radii = (r1 - r2)^2 - -instance Collisionable2 Collisioner2 where - - collideAABB2 box (AABB2Col self) = collideAABB2 box self - collideAABB2 box (CircleCol self) = collideAABB2 box self - - collideCircle circle (AABB2Col self) = collideCircle circle self - collideCircle circle (CircleCol self) = collideCircle circle self - -aabbPoints :: AABB2 -> [Vector2] -aabbPoints (AABB2 min max) = [p1,p2,p3,p4,p5,p6,p7,p8] - where - p1 = vec2 (x min) (y min) - p2 = vec2 (x min) (y min) - p3 = vec2 (x min) (y max) - p4 = vec2 (x min) (y max) - p5 = vec2 (x max) (y min) - p6 = vec2 (x max) (y min) - p7 = vec2 (x max) (y max) - p8 = vec2 (x max) (y max) - - --- | A collisioner component. -data Collisioner2 - -- | An axis-aligned bounding box. - = AABB2Col {-# UNPACK #-} !AABB2 - -- | A bounding circle. - | CircleCol {-# UNPACK #-} !Circle - - --- | Create a collisioner from the specified box. -aabb2Collisioner :: AABB2 -> Collisioner2 -aabb2Collisioner = AABB2Col - --- | Create a collisioner from the specified circle. -circleCollisioner :: Circle -> Collisioner2 -circleCollisioner = CircleCol - --- | Compute AABB collisioners in view space from the given AABB. -mkCols :: M4.Matrix4 -- ^ Modelview matrix - -> Box - -> [Collisioner2] -mkCols modelview (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = - let - toVec2 v = vec2 (x v) (y v) - p1 = toVec2 $ modelview `M4.mulp` vec3 xmin ymin zmax - p2 = toVec2 $ modelview `M4.mulp` vec3 xmax ymin zmin - p3 = toVec2 $ modelview `M4.mulp` vec3 xmax ymax zmin - col1 = AABB2Col $ AABB2 p1 p2 - col2 = AABB2Col $ AABB2 p1 p3 - in - [col1, col2] - --- | Create the minimal AABB fully containing the specified collisioners. -buildAABB2 :: [Collisioner2] -> AABB2 -buildAABB2 cols = aabb2 $ generatePoints cols - --- | Create the minimal box fully containing the specified circle. -aabb2FromCircle :: Circle -> AABB2 -aabb2FromCircle (Circle c r) = AABB2 bot top - where - bot = c - (vec2 r r) - top = c + (vec2 r r) - --- | Create the minimal circle fully containing the specified box. -circleFromAABB2 :: AABB2 -> Circle -circleFromAABB2 (AABB2 min max) = Circle c r - where - c = scale 0.5 (min + max) - r = norm . scale 0.5 $ max - min - -generatePoints :: [Collisioner2] -> [Vector2] -generatePoints = foldl' generate [] - where - generate acc (AABB2Col (AABB2 pmin pmax)) = p1:p2:p3:p4:p5:p6:p7:p8:acc - where - p1 = vec2 (x pmin) (y pmin) - p2 = vec2 (x pmin) (y pmin) - p3 = vec2 (x pmin) (y pmax) - p4 = vec2 (x pmin) (y pmax) - p5 = vec2 (x pmax) (y pmin) - p6 = vec2 (x pmax) (y pmin) - p7 = vec2 (x pmax) (y pmax) - p8 = vec2 (x pmax) (y pmax) - - generate acc (CircleCol (Circle c r)) = p1:p2:p3:p4:acc - where - p1 = c + unitx2 * (vec2 r r) - p2 = c - unitx2 * (vec2 r r) - p3 = c + unity2 * (vec2 r r) - p4 = c - unity2 * (vec2 r r) - --- | Collide the given collisioners. -collide :: Collisioner2 -> Collisioner2 -> CollisionType -collide (AABB2Col box1) (AABB2Col box2) = collideAABB2 box1 box2 -collide (AABB2Col box) (CircleCol circle) = collideAABB2 box circle -collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2 -collide (CircleCol circle) (AABB2Col box) = collideCircle circle box - --- | Move the collisioner. -move :: Vector2 -> Collisioner2 -> Collisioner2 -move v (AABB2Col (AABB2 min max)) = AABB2Col (AABB2 (min+v) (max+v)) -move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r) - - --- 3D collision - -class Collisionable3 a where - - -- | Collide the object with an AABB. - collideAABB3 :: AABB3 -> a -> CollisionType - - -- | Collide the object with a sphere. - collideSphere :: Sphere -> a -> CollisionType - -instance Collisionable3 AABB3 where - - collideAABB3 box1@(AABB3 min1 max1) box2@(AABB3 min2 max2) - | (x max1) < (x min2) = NoCollision - | (x min1) > (x max2) = NoCollision - | (y max1) < (y min2) = NoCollision - | (y min1) > (y max2) = NoCollision - | box1 `aabb3pt` min2 && box1 `aabb3pt` max2 = FullyContains - | box2 `aabb3pt` min1 && box2 `aabb3pt` max1 = FullyContainedBy - | otherwise = Collision - - collideSphere sphere@(Sphere c r) aabb@(AABB3 min max) - | test == FullyContains || test == FullyContainedBy = test - | normSq (c - boxC) > (l + r)^2 = NoCollision - | otherwise = Collision - where - test = collideAABB3 aabb $ aabb3FromSphere sphere - boxC = min + v - l = norm v - v = (max-min)/2 - -instance Collisionable3 Sphere where - - collideAABB3 box sphere = case collideSphere sphere box of - FullyContains -> FullyContainedBy - FullyContainedBy -> FullyContains - x -> x - - collideSphere s1@(Sphere c1 r1) s2@(Sphere c2 r2) - | distance_centers <= sub_radii = - if (r1 > r2) then FullyContains else FullyContainedBy - | distance_centers <= sum_radii = Collision - | otherwise = NoCollision - where - distance_centers = normSq $ c1 - c2 - sum_radii = (r1 + r2)^2 - sub_radii = (r1 - r2)^2 - --- | Create the minimal box fully containing the specified sphere. -aabb3FromSphere :: Sphere -> AABB3 -aabb3FromSphere (Sphere c r) = AABB3 bot top - where - bot = c - (vec3 r r r) +module Spear.Math.Collision +( + CollisionType(..) + -- * 2D Collision +, Collisionable2(..) +, Collisioner2(..) + -- ** Construction +, aabb2Collisioner +, circleCollisioner +, mkCols + -- ** Collision test +, collide + -- ** Manipulation +, move + -- ** Helpers +, buildAABB2 +, aabb2FromCircle +, circleFromAABB2 + -- * 3D Collision +, Collisionable3(..) + -- ** Helpers +, aabb3FromSphere +) +where + +import Spear.Assets.Model +import Spear.Math.AABB +import Spear.Math.Circle +import qualified Spear.Math.Matrix4 as M4 +import Spear.Math.Plane +import Spear.Math.Sphere +import Spear.Math.Vector + +import Data.List (foldl') + +data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy + deriving (Eq, Show) + +-- 2D collision + +class Collisionable2 a where + + -- | Collide the object with an AABB. + collideAABB2 :: AABB2 -> a -> CollisionType + + -- | Collide the object with a circle. + collideCircle :: Circle -> a -> CollisionType + +instance Collisionable2 AABB2 where + + collideAABB2 box1@(AABB2 min1 max1) box2@(AABB2 min2 max2) + | (x max1) < (x min2) = NoCollision + | (x min1) > (x max2) = NoCollision + | (y max1) < (y min2) = NoCollision + | (y min1) > (y max2) = NoCollision + | box1 `aabb2pt` min2 && box1 `aabb2pt` max2 = FullyContains + | box2 `aabb2pt` min1 && box2 `aabb2pt` max1 = FullyContainedBy + | otherwise = Collision + + collideCircle circle@(Circle c r) aabb@(AABB2 min max) + | test == FullyContains || test == FullyContainedBy = test + | normSq (c - boxC) > (l + r)^2 = NoCollision + | otherwise = Collision + where + test = collideAABB2 aabb $ aabb2FromCircle circle + boxC = min + (max-min)/2 + l = norm $ min + (vec2 (x boxC) (y min)) - min + +instance Collisionable2 Circle where + + collideAABB2 box circle = case collideCircle circle box of + FullyContains -> FullyContainedBy + FullyContainedBy -> FullyContains + x -> x + + collideCircle s1@(Circle c1 r1) s2@(Circle c2 r2) + | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy + | distance_centers <= sum_radii = Collision + | otherwise = NoCollision + where + distance_centers = normSq $ c1 - c2 + sum_radii = (r1 + r2)^2 + sub_radii = (r1 - r2)^2 + +instance Collisionable2 Collisioner2 where + + collideAABB2 box (AABB2Col self) = collideAABB2 box self + collideAABB2 box (CircleCol self) = collideAABB2 box self + + collideCircle circle (AABB2Col self) = collideCircle circle self + collideCircle circle (CircleCol self) = collideCircle circle self + +aabbPoints :: AABB2 -> [Vector2] +aabbPoints (AABB2 min max) = [p1,p2,p3,p4,p5,p6,p7,p8] + where + p1 = vec2 (x min) (y min) + p2 = vec2 (x min) (y min) + p3 = vec2 (x min) (y max) + p4 = vec2 (x min) (y max) + p5 = vec2 (x max) (y min) + p6 = vec2 (x max) (y min) + p7 = vec2 (x max) (y max) + p8 = vec2 (x max) (y max) + + +-- | A collisioner component. +data Collisioner2 + -- | An axis-aligned bounding box. + = AABB2Col {-# UNPACK #-} !AABB2 + -- | A bounding circle. + | CircleCol {-# UNPACK #-} !Circle + + +-- | Create a collisioner from the specified box. +aabb2Collisioner :: AABB2 -> Collisioner2 +aabb2Collisioner = AABB2Col + +-- | Create a collisioner from the specified circle. +circleCollisioner :: Circle -> Collisioner2 +circleCollisioner = CircleCol + +-- | Compute AABB collisioners in view space from the given AABB. +mkCols :: M4.Matrix4 -- ^ Modelview matrix + -> Box + -> [Collisioner2] +mkCols modelview (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = + let + toVec2 v = vec2 (x v) (y v) + p1 = toVec2 $ modelview `M4.mulp` vec3 xmin ymin zmax + p2 = toVec2 $ modelview `M4.mulp` vec3 xmax ymin zmin + p3 = toVec2 $ modelview `M4.mulp` vec3 xmax ymax zmin + col1 = AABB2Col $ AABB2 p1 p2 + col2 = AABB2Col $ AABB2 p1 p3 + in + [col1, col2] + +-- | Create the minimal AABB fully containing the specified collisioners. +buildAABB2 :: [Collisioner2] -> AABB2 +buildAABB2 cols = aabb2 $ generatePoints cols + +-- | Create the minimal box fully containing the specified circle. +aabb2FromCircle :: Circle -> AABB2 +aabb2FromCircle (Circle c r) = AABB2 bot top + where + bot = c - (vec2 r r) + top = c + (vec2 r r) + +-- | Create the minimal circle fully containing the specified box. +circleFromAABB2 :: AABB2 -> Circle +circleFromAABB2 (AABB2 min max) = Circle c r + where + c = scale 0.5 (min + max) + r = norm . scale 0.5 $ max - min + +generatePoints :: [Collisioner2] -> [Vector2] +generatePoints = foldl' generate [] + where + generate acc (AABB2Col (AABB2 pmin pmax)) = p1:p2:p3:p4:p5:p6:p7:p8:acc + where + p1 = vec2 (x pmin) (y pmin) + p2 = vec2 (x pmin) (y pmin) + p3 = vec2 (x pmin) (y pmax) + p4 = vec2 (x pmin) (y pmax) + p5 = vec2 (x pmax) (y pmin) + p6 = vec2 (x pmax) (y pmin) + p7 = vec2 (x pmax) (y pmax) + p8 = vec2 (x pmax) (y pmax) + + generate acc (CircleCol (Circle c r)) = p1:p2:p3:p4:acc + where + p1 = c + unitx2 * (vec2 r r) + p2 = c - unitx2 * (vec2 r r) + p3 = c + unity2 * (vec2 r r) + p4 = c - unity2 * (vec2 r r) + +-- | Collide the given collisioners. +collide :: Collisioner2 -> Collisioner2 -> CollisionType +collide (AABB2Col box1) (AABB2Col box2) = collideAABB2 box1 box2 +collide (AABB2Col box) (CircleCol circle) = collideAABB2 box circle +collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2 +collide (CircleCol circle) (AABB2Col box) = collideCircle circle box + +-- | Move the collisioner. +move :: Vector2 -> Collisioner2 -> Collisioner2 +move v (AABB2Col (AABB2 min max)) = AABB2Col (AABB2 (min+v) (max+v)) +move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r) + + +-- 3D collision + +class Collisionable3 a where + + -- | Collide the object with an AABB. + collideAABB3 :: AABB3 -> a -> CollisionType + + -- | Collide the object with a sphere. + collideSphere :: Sphere -> a -> CollisionType + +instance Collisionable3 AABB3 where + + collideAABB3 box1@(AABB3 min1 max1) box2@(AABB3 min2 max2) + | (x max1) < (x min2) = NoCollision + | (x min1) > (x max2) = NoCollision + | (y max1) < (y min2) = NoCollision + | (y min1) > (y max2) = NoCollision + | box1 `aabb3pt` min2 && box1 `aabb3pt` max2 = FullyContains + | box2 `aabb3pt` min1 && box2 `aabb3pt` max1 = FullyContainedBy + | otherwise = Collision + + collideSphere sphere@(Sphere c r) aabb@(AABB3 min max) + | test == FullyContains || test == FullyContainedBy = test + | normSq (c - boxC) > (l + r)^2 = NoCollision + | otherwise = Collision + where + test = collideAABB3 aabb $ aabb3FromSphere sphere + boxC = min + v + l = norm v + v = (max-min)/2 + +instance Collisionable3 Sphere where + + collideAABB3 box sphere = case collideSphere sphere box of + FullyContains -> FullyContainedBy + FullyContainedBy -> FullyContains + x -> x + + collideSphere s1@(Sphere c1 r1) s2@(Sphere c2 r2) + | distance_centers <= sub_radii = + if (r1 > r2) then FullyContains else FullyContainedBy + | distance_centers <= sum_radii = Collision + | otherwise = NoCollision + where + distance_centers = normSq $ c1 - c2 + sum_radii = (r1 + r2)^2 + sub_radii = (r1 - r2)^2 + +-- | Create the minimal box fully containing the specified sphere. +aabb3FromSphere :: Sphere -> AABB3 +aabb3FromSphere (Sphere c r) = AABB3 bot top + where + bot = c - (vec3 r r r) 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 @@ -module Spear.Math.Entity -( - Entity(..) -) -where - - -import qualified Spear.Math.Matrix3 as M -import qualified Spear.Math.Spatial2 as S -import qualified Spear.Math.Vector as V - - --- | An entity in 2D space. -newtype Entity = Entity { transform :: M.Matrix3 } - - -instance S.Spatial2 Entity where - move v ent = ent { transform = M.translv v * transform ent } - moveFwd f ent = ent { transform = M.translv (V.scale f $ S.fwd ent) * transform ent } - moveBack f ent = ent { transform = M.translv (V.scale (-f) $ S.fwd ent) * transform ent } - strafeLeft f ent = ent { transform = M.translv (V.scale (-f) $ S.right ent) * transform ent } - strafeRight f ent = ent { transform = M.translv (V.scale f $ S.right ent) * transform ent } - rotate a ent = ent { transform = transform ent * M.rot a } - setRotation a ent = - let t = transform ent - in ent { transform = M.translation t * M.rot a } - pos = M.position . transform - fwd = M.forward . transform - up = M.up . transform - right = M.right . transform - transform (Entity t) = t - setTransform t (Entity _) = Entity t - setPos pos (Entity t) = Entity $ M.transform (M.right t) (M.forward t) pos +module Spear.Math.Entity +( + Entity(..) +) +where + + +import qualified Spear.Math.Matrix3 as M +import qualified Spear.Math.Spatial2 as S +import qualified Spear.Math.Vector as V + + +-- | An entity in 2D space. +newtype Entity = Entity { transform :: M.Matrix3 } + + +instance S.Spatial2 Entity where + move v ent = ent { transform = M.translv v * transform ent } + moveFwd f ent = ent { transform = M.translv (V.scale f $ S.fwd ent) * transform ent } + moveBack f ent = ent { transform = M.translv (V.scale (-f) $ S.fwd ent) * transform ent } + strafeLeft f ent = ent { transform = M.translv (V.scale (-f) $ S.right ent) * transform ent } + strafeRight f ent = ent { transform = M.translv (V.scale f $ S.right ent) * transform ent } + rotate a ent = ent { transform = transform ent * M.rot a } + setRotation a ent = + let t = transform ent + in ent { transform = M.translation t * M.rot a } + pos = M.position . transform + fwd = M.forward . transform + up = M.up . transform + right = M.right . transform + transform (Entity t) = t + setTransform t (Entity _) = Entity t + 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 @@ -module Spear.Math.Frustum -where - -import Spear.Math.Plane - -data Frustum = Frustum - { n :: {-# UNPACK #-} !Plane - , f :: {-# UNPACK #-} !Plane - , l :: {-# UNPACK #-} !Plane - , r :: {-# UNPACK #-} !Plane - , t :: {-# UNPACK #-} !Plane - , b :: {-# UNPACK #-} !Plane - } deriving Show - --- | Construct a frustum. -frustum - :: Plane -- ^ Near - -> Plane -- ^ Far - -> Plane -- ^ Left - -> Plane -- ^ Right - -> Plane -- ^ Top - -> Plane -- ^ Bottom - -> Frustum -frustum = Frustum - --- | Construct a frustum. -fromList :: [Plane] -> Frustum -fromList (n:f:l:r:t:b:_) = Frustum n f l r t b +module Spear.Math.Frustum +where + +import Spear.Math.Plane + +data Frustum = Frustum + { n :: {-# UNPACK #-} !Plane + , f :: {-# UNPACK #-} !Plane + , l :: {-# UNPACK #-} !Plane + , r :: {-# UNPACK #-} !Plane + , t :: {-# UNPACK #-} !Plane + , b :: {-# UNPACK #-} !Plane + } deriving Show + +-- | Construct a frustum. +frustum + :: Plane -- ^ Near + -> Plane -- ^ Far + -> Plane -- ^ Left + -> Plane -- ^ Right + -> Plane -- ^ Top + -> Plane -- ^ Bottom + -> Frustum +frustum = Frustum + +-- | Construct a frustum. +fromList :: [Plane] -> Frustum +fromList (n:f:l:r:t:b:_) = Frustum n f l r t b diff --git a/Spear/Math/Matrix3.hs b/Spear/Math/Matrix3.hs index 497cb4e..7526827 100644 --- a/Spear/Math/Matrix3.hs +++ b/Spear/Math/Matrix3.hs @@ -1,335 +1,335 @@ -module Spear.Math.Matrix3 -( - Matrix3 - -- * Accessors -, m00, m01, m02 -, m10, m11, m12 -, m20, m21, m22 -, col0, col1, col2 -, row0, row1, row2 -, right, up, forward, position - -- * Construction -, mat3 -, mat3fromVec -, transform -, translation -, rotation -, Spear.Math.Matrix3.id - -- * Transformations - -- ** Translation -, transl -, translv - -- ** Rotation -, rot - -- ** Scale -, Spear.Math.Matrix3.scale -, scalev - -- ** Reflection -, reflectX -, reflectY -, reflectZ - -- * Operations -, transpose -, mulp -, muld -, mul -, inverseTransform -, Spear.Math.Matrix3.zipWith -, Spear.Math.Matrix3.map -) -where - - -import Spear.Math.Vector - -import Foreign.Storable - - --- | Represents a 3x3 column major matrix. -data Matrix3 = Matrix3 - { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float - , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float - , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float - } - - -instance Show Matrix3 where - - show (Matrix3 m00 m10 m20 m01 m11 m21 m02 m12 m22) = - show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ "\n" ++ - show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ "\n" ++ - show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ "\n" - where - show' f = if abs f < 0.0000001 then "0" else show f - - -instance Num Matrix3 where - (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) - + (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) - = Matrix3 (a00 + b00) (a01 + b01) (a02 + b02) - (a03 + b03) (a04 + b04) (a05 + b05) - (a06 + b06) (a07 + b07) (a08 + b08) - - (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) - - (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) - = Matrix3 (a00 - b00) (a01 - b01) (a02 - b02) - (a03 - b03) (a04 - b04) (a05 - b05) - (a06 - b06) (a07 - b07) (a08 - b08) - - (Matrix3 a00 a10 a20 a01 a11 a21 a02 a12 a22) - * (Matrix3 b00 b10 b20 b01 b11 b21 b02 b12 b22) - = Matrix3 (a00 * b00 + a10 * b01 + a20 * b02) - (a00 * b10 + a10 * b11 + a20 * b12) - (a00 * b20 + a10 * b21 + a20 * b22) - - (a01 * b00 + a11 * b01 + a21 * b02) - (a01 * b10 + a11 * b11 + a21 * b12) - (a01 * b20 + a11 * b21 + a21 * b22) - - (a02 * b00 + a12 * b01 + a22 * b02) - (a02 * b10 + a12 * b11 + a22 * b12) - (a02 * b20 + a12 * b21 + a22 * b22) - - abs = Spear.Math.Matrix3.map abs - - signum = Spear.Math.Matrix3.map signum - - fromInteger i = mat3 i' i' i' i' i' i' i' i' i' where i' = fromInteger i - - -instance Storable Matrix3 where - sizeOf _ = 36 - alignment _ = 4 - - peek ptr = do - a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; - a10 <- peekByteOff ptr 12; a11 <- peekByteOff ptr 16; a12 <- peekByteOff ptr 20; - a20 <- peekByteOff ptr 24; a21 <- peekByteOff ptr 28; a22 <- peekByteOff ptr 32; - - return $ Matrix3 a00 a10 a20 - a01 a11 a21 - a02 a12 a22 - - poke ptr (Matrix3 a00 a01 a02 - a10 a11 a12 - a20 a21 a22) = do - pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; - pokeByteOff ptr 12 a10; pokeByteOff ptr 16 a11; pokeByteOff ptr 20 a12; - pokeByteOff ptr 24 a20; pokeByteOff ptr 28 a21; pokeByteOff ptr 32 a22; - - -col0 (Matrix3 a00 _ _ a01 _ _ a02 _ _ ) = vec3 a00 a01 a02 -col1 (Matrix3 _ a10 _ _ a11 _ _ a12 _ ) = vec3 a10 a11 a12 -col2 (Matrix3 _ _ a20 _ _ a21 _ _ a22) = vec3 a20 a21 a22 - - -row0 (Matrix3 a00 a10 a20 _ _ _ _ _ _ ) = vec3 a00 a10 a20 -row1 (Matrix3 _ _ _ a01 a11 a21 _ _ _ ) = vec3 a01 a11 a21 -row2 (Matrix3 _ _ _ _ _ _ a02 a12 a22) = vec3 a02 a12 a22 - - -right (Matrix3 a00 _ _ a01 _ _ _ _ _) = vec2 a00 a01 -up (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 -forward (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 -position (Matrix3 _ _ a20 _ _ a21 _ _ _) = vec2 a20 a21 - - --- | Build a matrix from the specified values. -mat3 = Matrix3 - - --- | Build a matrix from three vectors in 3D. -mat3fromVec :: Vector3 -> Vector3 -> Vector3 -> Matrix3 -mat3fromVec v0 v1 v2 = Matrix3 - (x v0) (x v1) (x v2) - (y v0) (y v1) (y v2) - (z v0) (z v1) (z v2) - - --- | Build a transformation matrix. -transform :: Vector2 -- ^ Right vector - -> Vector2 -- ^ Forward vector - -> Vector2 -- ^ Position - -> Matrix3 -- ^ Transform - -transform r f p = mat3 - (x r) (x f) (x p) - (y r) (y f) (y p) - 0 0 1 - - --- | Get the translation part of the given transformation matrix. -translation :: Matrix3 -> Matrix3 -translation (Matrix3 - a00 a10 a20 - a01 a11 a21 - a02 a12 a22) - = mat3 - 1 0 a20 - 0 1 a21 - 0 0 a22 - - --- | Get the rotation part of the given transformationmatrix. -rotation :: Matrix3 -> Matrix3 -rotation (Matrix3 - a00 a10 a20 - a01 a11 a21 - a02 a12 a22) - = mat3 - a00 a10 0 - a01 a11 0 - a02 a12 1 - - --- | Return the identity matrix. -id :: Matrix3 -id = mat3 - 1 0 0 - 0 1 0 - 0 0 1 - - --- | Create a translation matrix. -transl :: Float -- ^ Translation on the x axis - -> Float -- ^ Translation on the y axis - -> Matrix3 - -transl tx ty = mat3 - 1 0 tx - 0 1 ty - 0 0 1 - - --- | Create a translation matrix. -translv :: Vector2 -> Matrix3 -translv v = mat3 - 1 0 (x v) - 0 1 (y v) - 0 0 1 - - --- | Create a rotation matrix rotating counter-clockwise about the Z axis. --- --- The given angle must be in degrees. -rot :: Float -> Matrix3 -rot angle = mat3 - c (-s) 0 - s c 0 - 0 0 1 - where - s = sin . fromDeg $ angle - c = cos . fromDeg $ angle - - --- | Create a scale matrix. -scale :: Float -> Float -> Float -> Matrix3 -scale sx sy sz = mat3 - sx 0 0 - 0 sy 0 - 0 0 sz - - --- | Create a scale matrix. -scalev :: Vector3 -> Matrix3 -scalev v = mat3 - sx 0 0 - 0 sy 0 - 0 0 sz - where - sx = x v - sy = y v - sz = z v - - --- | Create an X reflection matrix. -reflectX :: Matrix3 -reflectX = mat3 - (-1) 0 0 - 0 1 0 - 0 0 1 - - --- | Create a Y reflection matrix. -reflectY :: Matrix3 -reflectY = mat3 - 1 0 0 - 0 (-1) 0 - 0 0 1 - - --- | Create a Z reflection matrix. -reflectZ :: Matrix3 -reflectZ = mat3 - 1 0 0 - 0 1 0 - 0 0 (-1) - - --- | Transpose the specified matrix. -transpose :: Matrix3 -> Matrix3 -transpose m = mat3 - (m00 m) (m01 m) (m02 m) - (m10 m) (m11 m) (m12 m) - (m20 m) (m21 m) (m22 m) - - --- | Transform the given point vector in 2D space with the given matrix. -mulp :: Matrix3 -> Vector2 -> Vector2 -mulp m v = vec2 x' y' - where - v' = vec3 (x v) (y v) 1 - x' = row0 m `dot` v' - y' = row1 m `dot` v' - - - --- | Transform the given directional vector in 2D space with the given matrix. -muld :: Matrix3 -> Vector2 -> Vector2 -muld m v = vec2 x' y' - where - v' = vec3 (x v) (y v) 0 - x' = row0 m `dot` v' - y' = row1 m `dot` v' - - --- | Transform the given vector in 3D space with the given matrix. -mul :: Matrix3 -> Vector3 -> Vector3 -mul m v = vec3 x' y' z' - where - v' = vec3 (x v) (y v) (z v) - x' = row0 m `dot` v' - y' = row1 m `dot` v' - z' = row2 m `dot` v' - - --- | Zip two 'Matrix3' together with the specified function. -zipWith :: (Float -> Float -> Float) -> Matrix3 -> Matrix3 -> Matrix3 -zipWith f a b = Matrix3 - (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) - (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) - (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) - - --- | Map the specified function to the specified 'Matrix3'. -map :: (Float -> Float) -> Matrix3 -> Matrix3 -map f m = Matrix3 - (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) - (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) - (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) - - --- | Compute the inverse transform of the given transformation matrix. -inverseTransform :: Matrix3 -> Matrix3 -inverseTransform mat = - let r = right mat - f = forward mat - t = -(position mat) - in mat3 - (x r) (y r) (t `dot` r) - (x f) (y f) (t `dot` f) - 0 0 1 - - -fromDeg :: (Floating a) => a -> a -fromDeg = (*pi) . (/180) +module Spear.Math.Matrix3 +( + Matrix3 + -- * Accessors +, m00, m01, m02 +, m10, m11, m12 +, m20, m21, m22 +, col0, col1, col2 +, row0, row1, row2 +, right, up, forward, position + -- * Construction +, mat3 +, mat3fromVec +, transform +, translation +, rotation +, Spear.Math.Matrix3.id + -- * Transformations + -- ** Translation +, transl +, translv + -- ** Rotation +, rot + -- ** Scale +, Spear.Math.Matrix3.scale +, scalev + -- ** Reflection +, reflectX +, reflectY +, reflectZ + -- * Operations +, transpose +, mulp +, muld +, mul +, inverseTransform +, Spear.Math.Matrix3.zipWith +, Spear.Math.Matrix3.map +) +where + + +import Spear.Math.Vector + +import Foreign.Storable + + +-- | Represents a 3x3 column major matrix. +data Matrix3 = Matrix3 + { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float + , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float + , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float + } + + +instance Show Matrix3 where + + show (Matrix3 m00 m10 m20 m01 m11 m21 m02 m12 m22) = + show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ "\n" ++ + show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ "\n" ++ + show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ "\n" + where + show' f = if abs f < 0.0000001 then "0" else show f + + +instance Num Matrix3 where + (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) + + (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) + = Matrix3 (a00 + b00) (a01 + b01) (a02 + b02) + (a03 + b03) (a04 + b04) (a05 + b05) + (a06 + b06) (a07 + b07) (a08 + b08) + + (Matrix3 a00 a01 a02 a03 a04 a05 a06 a07 a08) + - (Matrix3 b00 b01 b02 b03 b04 b05 b06 b07 b08) + = Matrix3 (a00 - b00) (a01 - b01) (a02 - b02) + (a03 - b03) (a04 - b04) (a05 - b05) + (a06 - b06) (a07 - b07) (a08 - b08) + + (Matrix3 a00 a10 a20 a01 a11 a21 a02 a12 a22) + * (Matrix3 b00 b10 b20 b01 b11 b21 b02 b12 b22) + = Matrix3 (a00 * b00 + a10 * b01 + a20 * b02) + (a00 * b10 + a10 * b11 + a20 * b12) + (a00 * b20 + a10 * b21 + a20 * b22) + + (a01 * b00 + a11 * b01 + a21 * b02) + (a01 * b10 + a11 * b11 + a21 * b12) + (a01 * b20 + a11 * b21 + a21 * b22) + + (a02 * b00 + a12 * b01 + a22 * b02) + (a02 * b10 + a12 * b11 + a22 * b12) + (a02 * b20 + a12 * b21 + a22 * b22) + + abs = Spear.Math.Matrix3.map abs + + signum = Spear.Math.Matrix3.map signum + + fromInteger i = mat3 i' i' i' i' i' i' i' i' i' where i' = fromInteger i + + +instance Storable Matrix3 where + sizeOf _ = 36 + alignment _ = 4 + + peek ptr = do + a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; + a10 <- peekByteOff ptr 12; a11 <- peekByteOff ptr 16; a12 <- peekByteOff ptr 20; + a20 <- peekByteOff ptr 24; a21 <- peekByteOff ptr 28; a22 <- peekByteOff ptr 32; + + return $ Matrix3 a00 a10 a20 + a01 a11 a21 + a02 a12 a22 + + poke ptr (Matrix3 a00 a01 a02 + a10 a11 a12 + a20 a21 a22) = do + pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; + pokeByteOff ptr 12 a10; pokeByteOff ptr 16 a11; pokeByteOff ptr 20 a12; + pokeByteOff ptr 24 a20; pokeByteOff ptr 28 a21; pokeByteOff ptr 32 a22; + + +col0 (Matrix3 a00 _ _ a01 _ _ a02 _ _ ) = vec3 a00 a01 a02 +col1 (Matrix3 _ a10 _ _ a11 _ _ a12 _ ) = vec3 a10 a11 a12 +col2 (Matrix3 _ _ a20 _ _ a21 _ _ a22) = vec3 a20 a21 a22 + + +row0 (Matrix3 a00 a10 a20 _ _ _ _ _ _ ) = vec3 a00 a10 a20 +row1 (Matrix3 _ _ _ a01 a11 a21 _ _ _ ) = vec3 a01 a11 a21 +row2 (Matrix3 _ _ _ _ _ _ a02 a12 a22) = vec3 a02 a12 a22 + + +right (Matrix3 a00 _ _ a01 _ _ _ _ _) = vec2 a00 a01 +up (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 +forward (Matrix3 _ a10 _ _ a11 _ _ _ _) = vec2 a10 a11 +position (Matrix3 _ _ a20 _ _ a21 _ _ _) = vec2 a20 a21 + + +-- | Build a matrix from the specified values. +mat3 = Matrix3 + + +-- | Build a matrix from three vectors in 3D. +mat3fromVec :: Vector3 -> Vector3 -> Vector3 -> Matrix3 +mat3fromVec v0 v1 v2 = Matrix3 + (x v0) (x v1) (x v2) + (y v0) (y v1) (y v2) + (z v0) (z v1) (z v2) + + +-- | Build a transformation matrix. +transform :: Vector2 -- ^ Right vector + -> Vector2 -- ^ Forward vector + -> Vector2 -- ^ Position + -> Matrix3 -- ^ Transform + +transform r f p = mat3 + (x r) (x f) (x p) + (y r) (y f) (y p) + 0 0 1 + + +-- | Get the translation part of the given transformation matrix. +translation :: Matrix3 -> Matrix3 +translation (Matrix3 + a00 a10 a20 + a01 a11 a21 + a02 a12 a22) + = mat3 + 1 0 a20 + 0 1 a21 + 0 0 a22 + + +-- | Get the rotation part of the given transformationmatrix. +rotation :: Matrix3 -> Matrix3 +rotation (Matrix3 + a00 a10 a20 + a01 a11 a21 + a02 a12 a22) + = mat3 + a00 a10 0 + a01 a11 0 + a02 a12 1 + + +-- | Return the identity matrix. +id :: Matrix3 +id = mat3 + 1 0 0 + 0 1 0 + 0 0 1 + + +-- | Create a translation matrix. +transl :: Float -- ^ Translation on the x axis + -> Float -- ^ Translation on the y axis + -> Matrix3 + +transl tx ty = mat3 + 1 0 tx + 0 1 ty + 0 0 1 + + +-- | Create a translation matrix. +translv :: Vector2 -> Matrix3 +translv v = mat3 + 1 0 (x v) + 0 1 (y v) + 0 0 1 + + +-- | Create a rotation matrix rotating counter-clockwise about the Z axis. +-- +-- The given angle must be in degrees. +rot :: Float -> Matrix3 +rot angle = mat3 + c (-s) 0 + s c 0 + 0 0 1 + where + s = sin . fromDeg $ angle + c = cos . fromDeg $ angle + + +-- | Create a scale matrix. +scale :: Float -> Float -> Float -> Matrix3 +scale sx sy sz = mat3 + sx 0 0 + 0 sy 0 + 0 0 sz + + +-- | Create a scale matrix. +scalev :: Vector3 -> Matrix3 +scalev v = mat3 + sx 0 0 + 0 sy 0 + 0 0 sz + where + sx = x v + sy = y v + sz = z v + + +-- | Create an X reflection matrix. +reflectX :: Matrix3 +reflectX = mat3 + (-1) 0 0 + 0 1 0 + 0 0 1 + + +-- | Create a Y reflection matrix. +reflectY :: Matrix3 +reflectY = mat3 + 1 0 0 + 0 (-1) 0 + 0 0 1 + + +-- | Create a Z reflection matrix. +reflectZ :: Matrix3 +reflectZ = mat3 + 1 0 0 + 0 1 0 + 0 0 (-1) + + +-- | Transpose the specified matrix. +transpose :: Matrix3 -> Matrix3 +transpose m = mat3 + (m00 m) (m01 m) (m02 m) + (m10 m) (m11 m) (m12 m) + (m20 m) (m21 m) (m22 m) + + +-- | Transform the given point vector in 2D space with the given matrix. +mulp :: Matrix3 -> Vector2 -> Vector2 +mulp m v = vec2 x' y' + where + v' = vec3 (x v) (y v) 1 + x' = row0 m `dot` v' + y' = row1 m `dot` v' + + + +-- | Transform the given directional vector in 2D space with the given matrix. +muld :: Matrix3 -> Vector2 -> Vector2 +muld m v = vec2 x' y' + where + v' = vec3 (x v) (y v) 0 + x' = row0 m `dot` v' + y' = row1 m `dot` v' + + +-- | Transform the given vector in 3D space with the given matrix. +mul :: Matrix3 -> Vector3 -> Vector3 +mul m v = vec3 x' y' z' + where + v' = vec3 (x v) (y v) (z v) + x' = row0 m `dot` v' + y' = row1 m `dot` v' + z' = row2 m `dot` v' + + +-- | Zip two 'Matrix3' together with the specified function. +zipWith :: (Float -> Float -> Float) -> Matrix3 -> Matrix3 -> Matrix3 +zipWith f a b = Matrix3 + (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) + (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) + (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) + + +-- | Map the specified function to the specified 'Matrix3'. +map :: (Float -> Float) -> Matrix3 -> Matrix3 +map f m = Matrix3 + (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) + (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) + (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) + + +-- | Compute the inverse transform of the given transformation matrix. +inverseTransform :: Matrix3 -> Matrix3 +inverseTransform mat = + let r = right mat + f = forward mat + t = -(position mat) + in mat3 + (x r) (y r) (t `dot` r) + (x f) (y f) (t `dot` f) + 0 0 1 + + +fromDeg :: (Floating a) => a -> a +fromDeg = (*pi) . (/180) diff --git a/Spear/Math/Matrix4.hs b/Spear/Math/Matrix4.hs index e1b1d04..12eb031 100644 --- a/Spear/Math/Matrix4.hs +++ b/Spear/Math/Matrix4.hs @@ -1,650 +1,650 @@ -module Spear.Math.Matrix4 -( - Matrix4 - -- * Accessors -, m00, m01, m02, m03 -, m10, m11, m12, m13 -, m20, m21, m22, m23 -, m30, m31, m32, m33 -, col0, col1, col2, col3 -, row0, row1, row2, row3 -, right, up, forward, position - -- * Construction -, mat4 -, mat4fromVec -, transform -, translation -, rotation -, lookAt -, Spear.Math.Matrix4.id - -- * Transformations - -- ** Translation -, transl -, translv - -- ** Rotation -, rotX -, rotY -, rotZ -, axisAngle - -- ** Scale -, Spear.Math.Matrix4.scale -, scalev - -- ** Reflection -, reflectX -, reflectY -, reflectZ - -- ** Projection -, ortho -, perspective -, planeProj - -- * Operations -, Spear.Math.Matrix4.zipWith -, Spear.Math.Matrix4.map -, transpose -, inverseTransform -, inverse -, mul -, mulp -, muld -, mul' -) -where - - -import Spear.Math.Vector - -import Foreign.Storable - - --- | Represents a 4x4 column major matrix. -data Matrix4 = Matrix4 - { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float, m30 :: {-# UNPACK #-} !Float - , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float, m31 :: {-# UNPACK #-} !Float - , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float, m32 :: {-# UNPACK #-} !Float - , m03 :: {-# UNPACK #-} !Float, m13 :: {-# UNPACK #-} !Float, m23 :: {-# UNPACK #-} !Float, m33 :: {-# UNPACK #-} !Float - } - - -instance Show Matrix4 where - - show (Matrix4 m00 m10 m20 m30 m01 m11 m21 m31 m02 m12 m22 m32 m03 m13 m23 m33) = - show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ ", " ++ show' m30 ++ "\n" ++ - show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ ", " ++ show' m31 ++ "\n" ++ - show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ ", " ++ show' m32 ++ "\n" ++ - show' m03 ++ ", " ++ show' m13 ++ ", " ++ show' m23 ++ ", " ++ show' m33 ++ "\n" - where - show' f = if abs f < 0.0000001 then "0" else show f - - -instance Num Matrix4 where - (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) - + (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) - = Matrix4 (a00 + b00) (a01 + b01) (a02 + b02) (a03 + b03) - (a04 + b04) (a05 + b05) (a06 + b06) (a07 + b07) - (a08 + b08) (a09 + b09) (a10 + b10) (a11 + b11) - (a12 + b12) (a13 + b13) (a14 + b14) (a15 + b15) - - (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) - - (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) - = Matrix4 (a00 - b00) (a01 - b01) (a02 - b02) (a03 - b03) - (a04 - b04) (a05 - b05) (a06 - b06) (a07 - b07) - (a08 - b08) (a09 - b09) (a10 - b10) (a11 - b11) - (a12 - b12) (a13 - b13) (a14 - b14) (a15 - b15) - - (Matrix4 a00 a10 a20 a30 a01 a11 a21 a31 a02 a12 a22 a32 a03 a13 a23 a33) - * (Matrix4 b00 b10 b20 b30 b01 b11 b21 b31 b02 b12 b22 b32 b03 b13 b23 b33) - = Matrix4 (a00 * b00 + a10 * b01 + a20 * b02 + a30 * b03) - (a00 * b10 + a10 * b11 + a20 * b12 + a30 * b13) - (a00 * b20 + a10 * b21 + a20 * b22 + a30 * b23) - (a00 * b30 + a10 * b31 + a20 * b32 + a30 * b33) - - (a01 * b00 + a11 * b01 + a21 * b02 + a31 * b03) - (a01 * b10 + a11 * b11 + a21 * b12 + a31 * b13) - (a01 * b20 + a11 * b21 + a21 * b22 + a31 * b23) - (a01 * b30 + a11 * b31 + a21 * b32 + a31 * b33) - - (a02 * b00 + a12 * b01 + a22 * b02 + a32 * b03) - (a02 * b10 + a12 * b11 + a22 * b12 + a32 * b13) - (a02 * b20 + a12 * b21 + a22 * b22 + a32 * b23) - (a02 * b30 + a12 * b31 + a22 * b32 + a32 * b33) - - (a03 * b00 + a13 * b01 + a23 * b02 + a33 * b03) - (a03 * b10 + a13 * b11 + a23 * b12 + a33 * b13) - (a03 * b20 + a13 * b21 + a23 * b22 + a33 * b23) - (a03 * b30 + a13 * b31 + a23 * b32 + a33 * b33) - - abs = Spear.Math.Matrix4.map abs - - signum = Spear.Math.Matrix4.map signum - - fromInteger i = mat4 i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' where i' = fromInteger i - - -instance Storable Matrix4 where - sizeOf _ = 64 - alignment _ = 4 - - peek ptr = do - a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; a03 <- peekByteOff ptr 12; - a10 <- peekByteOff ptr 16; a11 <- peekByteOff ptr 20; a12 <- peekByteOff ptr 24; a13 <- peekByteOff ptr 28; - a20 <- peekByteOff ptr 32; a21 <- peekByteOff ptr 36; a22 <- peekByteOff ptr 40; a23 <- peekByteOff ptr 44; - a30 <- peekByteOff ptr 48; a31 <- peekByteOff ptr 52; a32 <- peekByteOff ptr 56; a33 <- peekByteOff ptr 60; - - return $ Matrix4 a00 a10 a20 a30 - a01 a11 a21 a31 - a02 a12 a22 a32 - a03 a13 a23 a33 - - poke ptr (Matrix4 a00 a10 a20 a30 - a01 a11 a21 a31 - a02 a12 a22 a32 - a03 a13 a23 a33) = do - pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; pokeByteOff ptr 12 a03; - pokeByteOff ptr 16 a10; pokeByteOff ptr 20 a11; pokeByteOff ptr 24 a12; pokeByteOff ptr 28 a13; - pokeByteOff ptr 32 a20; pokeByteOff ptr 36 a21; pokeByteOff ptr 40 a22; pokeByteOff ptr 44 a23; - pokeByteOff ptr 48 a30; pokeByteOff ptr 52 a31; pokeByteOff ptr 56 a32; pokeByteOff ptr 60 a33; - - -col0 (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ a03 _ _ _ ) = vec4 a00 a01 a02 a03 -col1 (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ a13 _ _ ) = vec4 a10 a11 a12 a13 -col2 (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ a23 _ ) = vec4 a20 a21 a22 a23 -col3 (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ a33) = vec4 a30 a31 a32 a33 - - -row0 (Matrix4 a00 a01 a02 a03 _ _ _ _ _ _ _ _ _ _ _ _ ) = vec4 a00 a01 a02 a03 -row1 (Matrix4 _ _ _ _ a10 a11 a12 a13 _ _ _ _ _ _ _ _ ) = vec4 a10 a11 a12 a13 -row2 (Matrix4 _ _ _ _ _ _ _ _ a20 a21 a22 a23 _ _ _ _ ) = vec4 a20 a21 a22 a23 -row3 (Matrix4 _ _ _ _ _ _ _ _ _ _ _ _ a30 a31 a32 a33) = vec4 a30 a31 a32 a33 - - -right (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ _ _ _ _) = vec3 a00 a01 a02 -up (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ _ _ _) = vec3 a10 a11 a12 -forward (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ _ _) = vec3 a20 a21 a22 -position (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ _) = vec3 a30 a31 a32 - - --- | Build a matrix from the specified values. -mat4 = Matrix4 - - --- | Build a matrix from four vectors in 4D. -mat4fromVec :: Vector4 -> Vector4 -> Vector4 -> Vector4 -> Matrix4 -mat4fromVec v0 v1 v2 v3 = Matrix4 - (x v0) (x v1) (x v2) (x v3) - (y v0) (y v1) (y v2) (y v3) - (z v0) (z v1) (z v2) (z v3) - (w v0) (w v1) (w v2) (w v3) - - --- | Build a transformation 'Matrix4' from the given vectors. -transform :: Vector3 -- ^ Right vector. - -> Vector3 -- ^ Up vector. - -> Vector3 -- ^ Forward vector. - -> Vector3 -- ^ Position. - -> Matrix4 - -transform right up fwd pos = mat4 - (x right) (x up) (x fwd) (x pos) - (y right) (y up) (y fwd) (y pos) - (z right) (z up) (z fwd) (z pos) - 0 0 0 1 - - --- | Get the translation part of the given transformation matrix. -translation :: Matrix4 -> Matrix4 -translation (Matrix4 - a00 a10 a20 a30 - a01 a11 a21 a31 - a02 a12 a22 a32 - a03 a13 a23 a33) - = mat4 - 1 0 0 a30 - 0 1 0 a31 - 0 0 1 a32 - 0 0 0 a33 - - --- | Get the rotation part of the given transformation matrix. -rotation :: Matrix4 -> Matrix4 -rotation (Matrix4 - a00 a10 a20 a30 - a01 a11 a21 a31 - a02 a12 a22 a32 - a03 a13 a23 a33) - = mat4 - a00 a10 a20 0 - a01 a11 a21 0 - a02 a12 a22 0 - a03 a13 a23 1 - - --- | Build a transformation 'Matrix4' defined by the given position and target. -lookAt :: Vector3 -- ^ Eye position. - -> Vector3 -- ^ Target point. - -> Matrix4 - -lookAt pos target = - let fwd = normalise $ target - pos - r = fwd `cross` unity3 - u = r `cross` fwd - in - transform r u (-fwd) pos - - --- | Zip two matrices together with the specified function. -zipWith :: (Float -> Float -> Float) -> Matrix4 -> Matrix4 -> Matrix4 -zipWith f a b = Matrix4 - (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) (f (m30 a) (m30 b)) - (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) (f (m31 a) (m31 b)) - (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) (f (m32 a) (m32 b)) - (f (m03 a) (m03 b)) (f (m13 a) (m13 b)) (f (m23 a) (m23 b)) (f (m33 a) (m33 b)) - - --- | Map the specified function to the specified matrix. -map :: (Float -> Float) -> Matrix4 -> Matrix4 -map f m = Matrix4 - (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) (f . m30 $ m) - (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) (f . m31 $ m) - (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) (f . m32 $ m) - (f . m03 $ m) (f . m13 $ m) (f . m23 $ m) (f . m33 $ m) - - --- | Return the identity matrix. -id :: Matrix4 -id = mat4 - 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - 0 0 0 1 - - --- | Create a translation matrix. -transl :: Float -> Float -> Float -> Matrix4 -transl x y z = mat4 - 1 0 0 x - 0 1 0 y - 0 0 1 z - 0 0 0 1 - - --- | Create a translation matrix. -translv :: Vector3 -> Matrix4 -translv v = mat4 - 1 0 0 (x v) - 0 1 0 (y v) - 0 0 1 (z v) - 0 0 0 1 - - --- | Create a rotation matrix rotating about the X axis. --- The given angle must be in degrees. -rotX :: Float -> Matrix4 -rotX angle = mat4 - 1 0 0 0 - 0 c (-s) 0 - 0 s c 0 - 0 0 0 1 - where - s = sin . toRAD $ angle - c = cos . toRAD $ angle - - --- | Create a rotation matrix rotating about the Y axis. --- The given angle must be in degrees. -rotY :: Float -> Matrix4 -rotY angle = mat4 - c 0 s 0 - 0 1 0 0 - (-s) 0 c 0 - 0 0 0 1 - where - s = sin . toRAD $ angle - c = cos . toRAD $ angle - - --- | Create a rotation matrix rotating about the Z axis. --- The given angle must be in degrees. -rotZ :: Float -> Matrix4 -rotZ angle = mat4 - c (-s) 0 0 - s c 0 0 - 0 0 1 0 - 0 0 0 1 - where - s = sin . toRAD $ angle - c = cos . toRAD $ angle - - --- | Create a rotation matrix rotating about the specified axis. --- The given angle must be in degrees. -axisAngle :: Vector3 -> Float -> Matrix4 -axisAngle v angle = mat4 - (c + omc*ax^2) (omc*xy-sz) (omc*xz+sy) 0 - (omc*xy+sz) (c+omc*ay^2) (omc*yz-sx) 0 - (omc*xz-sy) (omc*yz+sx) (c+omc*az^2) 0 - 0 0 0 1 - where - ax = x v - ay = y v - az = z v - s = sin . toRAD $ angle - c = cos . toRAD $ angle - xy = ax*ay - xz = ax*az - yz = ay*az - sx = s*ax - sy = s*ay - sz = s*az - omc = 1 - c - - --- | Create a scale matrix. -scale :: Float -> Float -> Float -> Matrix4 -scale sx sy sz = mat4 - sx 0 0 0 - 0 sy 0 0 - 0 0 sz 0 - 0 0 0 1 - - --- | Create a scale matrix. -scalev :: Vector3 -> Matrix4 -scalev v = mat4 - sx 0 0 0 - 0 sy 0 0 - 0 0 sz 0 - 0 0 0 1 - where - sx = x v - sy = y v - sz = z v - - --- | Create an X reflection matrix. -reflectX :: Matrix4 -reflectX = mat4 - (-1) 0 0 0 - 0 1 0 0 - 0 0 1 0 - 0 0 0 1 - - --- | Create a Y reflection matrix. -reflectY :: Matrix4 -reflectY = mat4 - 1 0 0 0 - 0 (-1) 0 0 - 0 0 1 0 - 0 0 0 1 - - --- | Create a Z reflection matrix. -reflectZ :: Matrix4 -reflectZ = mat4 - 1 0 0 0 - 0 1 0 0 - 0 0 (-1) 0 - 0 0 0 1 - - --- | Create an orthogonal projection matrix. -ortho :: Float -- ^ Left. - -> Float -- ^ Right. - -> Float -- ^ Bottom. - -> Float -- ^ Top. - -> Float -- ^ Near clip. - -> Float -- ^ Far clip. - -> Matrix4 - -ortho l r b t n f = - let tx = (-(r+l)/(r-l)) - ty = (-(t+b)/(t-b)) - tz = (-(f+n)/(f-n)) - in mat4 - (2/(r-l)) 0 0 tx - 0 (2/(t-b)) 0 ty - 0 0 ((-2)/(f-n)) tz - 0 0 0 1 - - --- | Create a perspective projection matrix. -perspective :: Float -- ^ Fovy - Vertical field of view angle in degrees. - -> Float -- ^ Aspect ratio. - -> Float -- ^ Near clip distance. - -> Float -- ^ Far clip distance - -> Matrix4 -perspective fovy r near far = - let f = 1 / tan (toRAD fovy / 2) - a = near - far - in mat4 - (f/r) 0 0 0 - 0 f 0 0 - 0 0 ((near+far)/a) (2*near*far/a) - 0 0 (-1) 0 - - --- | Create a plane projection matrix. -planeProj :: Vector3 -- ^ Plane normal - -> Float -- ^ Plane distance from the origin - -> Vector3 -- ^ Projection direction - -> Matrix4 -planeProj n d l = - let c = n `dot` l - nx = x n - ny = y n - nz = z n - lx = x l - ly = y l - lz = z l - in mat4 - (d + c - nx*lx) (-ny*lx) (-nz*lx) (-lx*d) - (-nx*ly) (d + c - ny*ly) (-nz*ly) (-ly*d) - (-nx*lz) (-ny*lz) (d + c - nz*lz) (-lz*d) - (-nx) (-ny) (-nz) c - - --- | Transpose the specified matrix. -transpose :: Matrix4 -> Matrix4 -transpose m = mat4 - (m00 m) (m01 m) (m02 m) (m03 m) - (m10 m) (m11 m) (m12 m) (m13 m) - (m20 m) (m21 m) (m22 m) (m23 m) - (m30 m) (m31 m) (m32 m) (m33 m) - - --- | Invert the given transformation matrix. -inverseTransform :: Matrix4 -> Matrix4 -inverseTransform mat = - let - r = right mat - u = up mat - f = forward mat - t = position mat - in - mat4 - (x r) (y r) (z r) (-t `dot` r) - (x u) (y u) (z u) (-t `dot` u) - (x f) (y f) (z f) (-t `dot` f) - 0 0 0 1 - - --- | Invert the given matrix. -inverse :: Matrix4 -> Matrix4 -inverse mat = - let - a00 = m00 mat - a01 = m01 mat - a02 = m02 mat - a03 = m03 mat - a04 = m10 mat - a05 = m11 mat - a06 = m12 mat - a07 = m13 mat - a08 = m20 mat - a09 = m21 mat - a10 = m22 mat - a11 = m23 mat - a12 = m30 mat - a13 = m31 mat - a14 = m32 mat - a15 = m33 mat - - m00' = a05 * a10 * a15 - - a05 * a11 * a14 - - a09 * a06 * a15 - + a09 * a07 * a14 - + a13 * a06 * a11 - - a13 * a07 * a10 - - m04' = -a04 * a10 * a15 - + a04 * a11 * a14 - + a08 * a06 * a15 - - a08 * a07 * a14 - - a12 * a06 * a11 - + a12 * a07 * a10 - - m08' = a04 * a09 * a15 - - a04 * a11 * a13 - - a08 * a05 * a15 - + a08 * a07 * a13 - + a12 * a05 * a11 - - a12 * a07 * a09 - - m12' = -a04 * a09 * a14 - + a04 * a10 * a13 - + a08 * a05 * a14 - - a08 * a06 * a13 - - a12 * a05 * a10 - + a12 * a06 * a09 - - m01' = -a01 * a10 * a15 - + a01 * a11 * a14 - + a09 * a02 * a15 - - a09 * a03 * a14 - - a13 * a02 * a11 - + a13 * a03 * a10 - - m05' = a00 * a10 * a15 - - a00 * a11 * a14 - - a08 * a02 * a15 - + a08 * a03 * a14 - + a12 * a02 * a11 - - a12 * a03 * a10 - - m09' = -a00 * a09 * a15 - + a00 * a11 * a13 - + a08 * a01 * a15 - - a08 * a03 * a13 - - a12 * a01 * a11 - + a12 * a03 * a09 - - m13' = a00 * a09 * a14 - - a00 * a10 * a13 - - a08 * a01 * a14 - + a08 * a02 * a13 - + a12 * a01 * a10 - - a12 * a02 * a09 - - m02' = a01 * a06 * a15 - - a01 * a07 * a14 - - a05 * a02 * a15 - + a05 * a03 * a14 - + a13 * a02 * a07 - - a13 * a03 * a06 - - m06' = -a00 * a06 * a15 - + a00 * a07 * a14 - + a04 * a02 * a15 - - a04 * a03 * a14 - - a12 * a02 * a07 - + a12 * a03 * a06 - - m10' = a00 * a05 * a15 - - a00 * a07 * a13 - - a04 * a01 * a15 - + a04 * a03 * a13 - + a12 * a01 * a07 - - a12 * a03 * a05 - - m14' = -a00 * a05 * a14 - + a00 * a06 * a13 - + a04 * a01 * a14 - - a04 * a02 * a13 - - a12 * a01 * a06 - + a12 * a02 * a05 - - m03' = -a01 * a06 * a11 - + a01 * a07 * a10 - + a05 * a02 * a11 - - a05 * a03 * a10 - - a09 * a02 * a07 - + a09 * a03 * a06 - - m07' = a00 * a06 * a11 - - a00 * a07 * a10 - - a04 * a02 * a11 - + a04 * a03 * a10 - + a08 * a02 * a07 - - a08 * a03 * a06 - - m11' = -a00 * a05 * a11 - + a00 * a07 * a09 - + a04 * a01 * a11 - - a04 * a03 * a09 - - a08 * a01 * a07 - + a08 * a03 * a05 - - m15' = a00 * a05 * a10 - - a00 * a06 * a09 - - a04 * a01 * a10 - + a04 * a02 * a09 - + a08 * a01 * a06 - - a08 * a02 * a05 - - det' = a00 * m00' + a01 * m04' + a02 * m08' + a03 * m12' - in - if det' == 0 then Spear.Math.Matrix4.id - else - let det = 1 / det' - in mat4 - (m00' * det) (m04' * det) (m08' * det) (m12' * det) - (m01' * det) (m05' * det) (m09' * det) (m13' * det) - (m02' * det) (m06' * det) (m10' * det) (m14' * det) - (m03' * det) (m07' * det) (m11' * det) (m15' * det) - - --- | Transform the given vector in 3D space with the given matrix. -mul :: Float -> Matrix4 -> Vector3 -> Vector3 -mul w m v = vec3 x' y' z' - where - v' = vec4 (x v) (y v) (z v) w - x' = row0 m `dot` v' - y' = row1 m `dot` v' - z' = row2 m `dot` v' - - --- | Transform the given point vector in 3D space with the given matrix. -mulp :: Matrix4 -> Vector3 -> Vector3 -mulp = mul 1 - - --- | Transform the given directional vector in 3D space with the given matrix. -muld :: Matrix4 -> Vector3 -> Vector3 -muld = mul 0 - - --- | Transform the given vector with the given matrix. --- --- The vector is brought from homogeneous space to 3D space by performing a --- perspective divide. -mul' :: Float -> Matrix4 -> Vector3 -> Vector3 -mul' w m v = vec3 (x'/w') (y'/w') (z'/w') - where - v' = vec4 (x v) (y v) (z v) w - x' = row0 m `dot` v' - y' = row1 m `dot` v' - z' = row2 m `dot` v' - w' = row3 m `dot` v' - - -toRAD = (*pi) . (/180) +module Spear.Math.Matrix4 +( + Matrix4 + -- * Accessors +, m00, m01, m02, m03 +, m10, m11, m12, m13 +, m20, m21, m22, m23 +, m30, m31, m32, m33 +, col0, col1, col2, col3 +, row0, row1, row2, row3 +, right, up, forward, position + -- * Construction +, mat4 +, mat4fromVec +, transform +, translation +, rotation +, lookAt +, Spear.Math.Matrix4.id + -- * Transformations + -- ** Translation +, transl +, translv + -- ** Rotation +, rotX +, rotY +, rotZ +, axisAngle + -- ** Scale +, Spear.Math.Matrix4.scale +, scalev + -- ** Reflection +, reflectX +, reflectY +, reflectZ + -- ** Projection +, ortho +, perspective +, planeProj + -- * Operations +, Spear.Math.Matrix4.zipWith +, Spear.Math.Matrix4.map +, transpose +, inverseTransform +, inverse +, mul +, mulp +, muld +, mul' +) +where + + +import Spear.Math.Vector + +import Foreign.Storable + + +-- | Represents a 4x4 column major matrix. +data Matrix4 = Matrix4 + { m00 :: {-# UNPACK #-} !Float, m10 :: {-# UNPACK #-} !Float, m20 :: {-# UNPACK #-} !Float, m30 :: {-# UNPACK #-} !Float + , m01 :: {-# UNPACK #-} !Float, m11 :: {-# UNPACK #-} !Float, m21 :: {-# UNPACK #-} !Float, m31 :: {-# UNPACK #-} !Float + , m02 :: {-# UNPACK #-} !Float, m12 :: {-# UNPACK #-} !Float, m22 :: {-# UNPACK #-} !Float, m32 :: {-# UNPACK #-} !Float + , m03 :: {-# UNPACK #-} !Float, m13 :: {-# UNPACK #-} !Float, m23 :: {-# UNPACK #-} !Float, m33 :: {-# UNPACK #-} !Float + } + + +instance Show Matrix4 where + + show (Matrix4 m00 m10 m20 m30 m01 m11 m21 m31 m02 m12 m22 m32 m03 m13 m23 m33) = + show' m00 ++ ", " ++ show' m10 ++ ", " ++ show' m20 ++ ", " ++ show' m30 ++ "\n" ++ + show' m01 ++ ", " ++ show' m11 ++ ", " ++ show' m21 ++ ", " ++ show' m31 ++ "\n" ++ + show' m02 ++ ", " ++ show' m12 ++ ", " ++ show' m22 ++ ", " ++ show' m32 ++ "\n" ++ + show' m03 ++ ", " ++ show' m13 ++ ", " ++ show' m23 ++ ", " ++ show' m33 ++ "\n" + where + show' f = if abs f < 0.0000001 then "0" else show f + + +instance Num Matrix4 where + (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) + + (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) + = Matrix4 (a00 + b00) (a01 + b01) (a02 + b02) (a03 + b03) + (a04 + b04) (a05 + b05) (a06 + b06) (a07 + b07) + (a08 + b08) (a09 + b09) (a10 + b10) (a11 + b11) + (a12 + b12) (a13 + b13) (a14 + b14) (a15 + b15) + + (Matrix4 a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14 a15) + - (Matrix4 b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) + = Matrix4 (a00 - b00) (a01 - b01) (a02 - b02) (a03 - b03) + (a04 - b04) (a05 - b05) (a06 - b06) (a07 - b07) + (a08 - b08) (a09 - b09) (a10 - b10) (a11 - b11) + (a12 - b12) (a13 - b13) (a14 - b14) (a15 - b15) + + (Matrix4 a00 a10 a20 a30 a01 a11 a21 a31 a02 a12 a22 a32 a03 a13 a23 a33) + * (Matrix4 b00 b10 b20 b30 b01 b11 b21 b31 b02 b12 b22 b32 b03 b13 b23 b33) + = Matrix4 (a00 * b00 + a10 * b01 + a20 * b02 + a30 * b03) + (a00 * b10 + a10 * b11 + a20 * b12 + a30 * b13) + (a00 * b20 + a10 * b21 + a20 * b22 + a30 * b23) + (a00 * b30 + a10 * b31 + a20 * b32 + a30 * b33) + + (a01 * b00 + a11 * b01 + a21 * b02 + a31 * b03) + (a01 * b10 + a11 * b11 + a21 * b12 + a31 * b13) + (a01 * b20 + a11 * b21 + a21 * b22 + a31 * b23) + (a01 * b30 + a11 * b31 + a21 * b32 + a31 * b33) + + (a02 * b00 + a12 * b01 + a22 * b02 + a32 * b03) + (a02 * b10 + a12 * b11 + a22 * b12 + a32 * b13) + (a02 * b20 + a12 * b21 + a22 * b22 + a32 * b23) + (a02 * b30 + a12 * b31 + a22 * b32 + a32 * b33) + + (a03 * b00 + a13 * b01 + a23 * b02 + a33 * b03) + (a03 * b10 + a13 * b11 + a23 * b12 + a33 * b13) + (a03 * b20 + a13 * b21 + a23 * b22 + a33 * b23) + (a03 * b30 + a13 * b31 + a23 * b32 + a33 * b33) + + abs = Spear.Math.Matrix4.map abs + + signum = Spear.Math.Matrix4.map signum + + fromInteger i = mat4 i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' i' where i' = fromInteger i + + +instance Storable Matrix4 where + sizeOf _ = 64 + alignment _ = 4 + + peek ptr = do + a00 <- peekByteOff ptr 0; a01 <- peekByteOff ptr 4; a02 <- peekByteOff ptr 8; a03 <- peekByteOff ptr 12; + a10 <- peekByteOff ptr 16; a11 <- peekByteOff ptr 20; a12 <- peekByteOff ptr 24; a13 <- peekByteOff ptr 28; + a20 <- peekByteOff ptr 32; a21 <- peekByteOff ptr 36; a22 <- peekByteOff ptr 40; a23 <- peekByteOff ptr 44; + a30 <- peekByteOff ptr 48; a31 <- peekByteOff ptr 52; a32 <- peekByteOff ptr 56; a33 <- peekByteOff ptr 60; + + return $ Matrix4 a00 a10 a20 a30 + a01 a11 a21 a31 + a02 a12 a22 a32 + a03 a13 a23 a33 + + poke ptr (Matrix4 a00 a10 a20 a30 + a01 a11 a21 a31 + a02 a12 a22 a32 + a03 a13 a23 a33) = do + pokeByteOff ptr 0 a00; pokeByteOff ptr 4 a01; pokeByteOff ptr 8 a02; pokeByteOff ptr 12 a03; + pokeByteOff ptr 16 a10; pokeByteOff ptr 20 a11; pokeByteOff ptr 24 a12; pokeByteOff ptr 28 a13; + pokeByteOff ptr 32 a20; pokeByteOff ptr 36 a21; pokeByteOff ptr 40 a22; pokeByteOff ptr 44 a23; + pokeByteOff ptr 48 a30; pokeByteOff ptr 52 a31; pokeByteOff ptr 56 a32; pokeByteOff ptr 60 a33; + + +col0 (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ a03 _ _ _ ) = vec4 a00 a01 a02 a03 +col1 (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ a13 _ _ ) = vec4 a10 a11 a12 a13 +col2 (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ a23 _ ) = vec4 a20 a21 a22 a23 +col3 (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ a33) = vec4 a30 a31 a32 a33 + + +row0 (Matrix4 a00 a01 a02 a03 _ _ _ _ _ _ _ _ _ _ _ _ ) = vec4 a00 a01 a02 a03 +row1 (Matrix4 _ _ _ _ a10 a11 a12 a13 _ _ _ _ _ _ _ _ ) = vec4 a10 a11 a12 a13 +row2 (Matrix4 _ _ _ _ _ _ _ _ a20 a21 a22 a23 _ _ _ _ ) = vec4 a20 a21 a22 a23 +row3 (Matrix4 _ _ _ _ _ _ _ _ _ _ _ _ a30 a31 a32 a33) = vec4 a30 a31 a32 a33 + + +right (Matrix4 a00 _ _ _ a01 _ _ _ a02 _ _ _ _ _ _ _) = vec3 a00 a01 a02 +up (Matrix4 _ a10 _ _ _ a11 _ _ _ a12 _ _ _ _ _ _) = vec3 a10 a11 a12 +forward (Matrix4 _ _ a20 _ _ _ a21 _ _ _ a22 _ _ _ _ _) = vec3 a20 a21 a22 +position (Matrix4 _ _ _ a30 _ _ _ a31 _ _ _ a32 _ _ _ _) = vec3 a30 a31 a32 + + +-- | Build a matrix from the specified values. +mat4 = Matrix4 + + +-- | Build a matrix from four vectors in 4D. +mat4fromVec :: Vector4 -> Vector4 -> Vector4 -> Vector4 -> Matrix4 +mat4fromVec v0 v1 v2 v3 = Matrix4 + (x v0) (x v1) (x v2) (x v3) + (y v0) (y v1) (y v2) (y v3) + (z v0) (z v1) (z v2) (z v3) + (w v0) (w v1) (w v2) (w v3) + + +-- | Build a transformation 'Matrix4' from the given vectors. +transform :: Vector3 -- ^ Right vector. + -> Vector3 -- ^ Up vector. + -> Vector3 -- ^ Forward vector. + -> Vector3 -- ^ Position. + -> Matrix4 + +transform right up fwd pos = mat4 + (x right) (x up) (x fwd) (x pos) + (y right) (y up) (y fwd) (y pos) + (z right) (z up) (z fwd) (z pos) + 0 0 0 1 + + +-- | Get the translation part of the given transformation matrix. +translation :: Matrix4 -> Matrix4 +translation (Matrix4 + a00 a10 a20 a30 + a01 a11 a21 a31 + a02 a12 a22 a32 + a03 a13 a23 a33) + = mat4 + 1 0 0 a30 + 0 1 0 a31 + 0 0 1 a32 + 0 0 0 a33 + + +-- | Get the rotation part of the given transformation matrix. +rotation :: Matrix4 -> Matrix4 +rotation (Matrix4 + a00 a10 a20 a30 + a01 a11 a21 a31 + a02 a12 a22 a32 + a03 a13 a23 a33) + = mat4 + a00 a10 a20 0 + a01 a11 a21 0 + a02 a12 a22 0 + a03 a13 a23 1 + + +-- | Build a transformation 'Matrix4' defined by the given position and target. +lookAt :: Vector3 -- ^ Eye position. + -> Vector3 -- ^ Target point. + -> Matrix4 + +lookAt pos target = + let fwd = normalise $ target - pos + r = fwd `cross` unity3 + u = r `cross` fwd + in + transform r u (-fwd) pos + + +-- | Zip two matrices together with the specified function. +zipWith :: (Float -> Float -> Float) -> Matrix4 -> Matrix4 -> Matrix4 +zipWith f a b = Matrix4 + (f (m00 a) (m00 b)) (f (m10 a) (m10 b)) (f (m20 a) (m20 b)) (f (m30 a) (m30 b)) + (f (m01 a) (m01 b)) (f (m11 a) (m11 b)) (f (m21 a) (m21 b)) (f (m31 a) (m31 b)) + (f (m02 a) (m02 b)) (f (m12 a) (m12 b)) (f (m22 a) (m22 b)) (f (m32 a) (m32 b)) + (f (m03 a) (m03 b)) (f (m13 a) (m13 b)) (f (m23 a) (m23 b)) (f (m33 a) (m33 b)) + + +-- | Map the specified function to the specified matrix. +map :: (Float -> Float) -> Matrix4 -> Matrix4 +map f m = Matrix4 + (f . m00 $ m) (f . m10 $ m) (f . m20 $ m) (f . m30 $ m) + (f . m01 $ m) (f . m11 $ m) (f . m21 $ m) (f . m31 $ m) + (f . m02 $ m) (f . m12 $ m) (f . m22 $ m) (f . m32 $ m) + (f . m03 $ m) (f . m13 $ m) (f . m23 $ m) (f . m33 $ m) + + +-- | Return the identity matrix. +id :: Matrix4 +id = mat4 + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + 0 0 0 1 + + +-- | Create a translation matrix. +transl :: Float -> Float -> Float -> Matrix4 +transl x y z = mat4 + 1 0 0 x + 0 1 0 y + 0 0 1 z + 0 0 0 1 + + +-- | Create a translation matrix. +translv :: Vector3 -> Matrix4 +translv v = mat4 + 1 0 0 (x v) + 0 1 0 (y v) + 0 0 1 (z v) + 0 0 0 1 + + +-- | Create a rotation matrix rotating about the X axis. +-- The given angle must be in degrees. +rotX :: Float -> Matrix4 +rotX angle = mat4 + 1 0 0 0 + 0 c (-s) 0 + 0 s c 0 + 0 0 0 1 + where + s = sin . toRAD $ angle + c = cos . toRAD $ angle + + +-- | Create a rotation matrix rotating about the Y axis. +-- The given angle must be in degrees. +rotY :: Float -> Matrix4 +rotY angle = mat4 + c 0 s 0 + 0 1 0 0 + (-s) 0 c 0 + 0 0 0 1 + where + s = sin . toRAD $ angle + c = cos . toRAD $ angle + + +-- | Create a rotation matrix rotating about the Z axis. +-- The given angle must be in degrees. +rotZ :: Float -> Matrix4 +rotZ angle = mat4 + c (-s) 0 0 + s c 0 0 + 0 0 1 0 + 0 0 0 1 + where + s = sin . toRAD $ angle + c = cos . toRAD $ angle + + +-- | Create a rotation matrix rotating about the specified axis. +-- The given angle must be in degrees. +axisAngle :: Vector3 -> Float -> Matrix4 +axisAngle v angle = mat4 + (c + omc*ax^2) (omc*xy-sz) (omc*xz+sy) 0 + (omc*xy+sz) (c+omc*ay^2) (omc*yz-sx) 0 + (omc*xz-sy) (omc*yz+sx) (c+omc*az^2) 0 + 0 0 0 1 + where + ax = x v + ay = y v + az = z v + s = sin . toRAD $ angle + c = cos . toRAD $ angle + xy = ax*ay + xz = ax*az + yz = ay*az + sx = s*ax + sy = s*ay + sz = s*az + omc = 1 - c + + +-- | Create a scale matrix. +scale :: Float -> Float -> Float -> Matrix4 +scale sx sy sz = mat4 + sx 0 0 0 + 0 sy 0 0 + 0 0 sz 0 + 0 0 0 1 + + +-- | Create a scale matrix. +scalev :: Vector3 -> Matrix4 +scalev v = mat4 + sx 0 0 0 + 0 sy 0 0 + 0 0 sz 0 + 0 0 0 1 + where + sx = x v + sy = y v + sz = z v + + +-- | Create an X reflection matrix. +reflectX :: Matrix4 +reflectX = mat4 + (-1) 0 0 0 + 0 1 0 0 + 0 0 1 0 + 0 0 0 1 + + +-- | Create a Y reflection matrix. +reflectY :: Matrix4 +reflectY = mat4 + 1 0 0 0 + 0 (-1) 0 0 + 0 0 1 0 + 0 0 0 1 + + +-- | Create a Z reflection matrix. +reflectZ :: Matrix4 +reflectZ = mat4 + 1 0 0 0 + 0 1 0 0 + 0 0 (-1) 0 + 0 0 0 1 + + +-- | Create an orthogonal projection matrix. +ortho :: Float -- ^ Left. + -> Float -- ^ Right. + -> Float -- ^ Bottom. + -> Float -- ^ Top. + -> Float -- ^ Near clip. + -> Float -- ^ Far clip. + -> Matrix4 + +ortho l r b t n f = + let tx = (-(r+l)/(r-l)) + ty = (-(t+b)/(t-b)) + tz = (-(f+n)/(f-n)) + in mat4 + (2/(r-l)) 0 0 tx + 0 (2/(t-b)) 0 ty + 0 0 ((-2)/(f-n)) tz + 0 0 0 1 + + +-- | Create a perspective projection matrix. +perspective :: Float -- ^ Fovy - Vertical field of view angle in degrees. + -> Float -- ^ Aspect ratio. + -> Float -- ^ Near clip distance. + -> Float -- ^ Far clip distance + -> Matrix4 +perspective fovy r near far = + let f = 1 / tan (toRAD fovy / 2) + a = near - far + in mat4 + (f/r) 0 0 0 + 0 f 0 0 + 0 0 ((near+far)/a) (2*near*far/a) + 0 0 (-1) 0 + + +-- | Create a plane projection matrix. +planeProj :: Vector3 -- ^ Plane normal + -> Float -- ^ Plane distance from the origin + -> Vector3 -- ^ Projection direction + -> Matrix4 +planeProj n d l = + let c = n `dot` l + nx = x n + ny = y n + nz = z n + lx = x l + ly = y l + lz = z l + in mat4 + (d + c - nx*lx) (-ny*lx) (-nz*lx) (-lx*d) + (-nx*ly) (d + c - ny*ly) (-nz*ly) (-ly*d) + (-nx*lz) (-ny*lz) (d + c - nz*lz) (-lz*d) + (-nx) (-ny) (-nz) c + + +-- | Transpose the specified matrix. +transpose :: Matrix4 -> Matrix4 +transpose m = mat4 + (m00 m) (m01 m) (m02 m) (m03 m) + (m10 m) (m11 m) (m12 m) (m13 m) + (m20 m) (m21 m) (m22 m) (m23 m) + (m30 m) (m31 m) (m32 m) (m33 m) + + +-- | Invert the given transformation matrix. +inverseTransform :: Matrix4 -> Matrix4 +inverseTransform mat = + let + r = right mat + u = up mat + f = forward mat + t = position mat + in + mat4 + (x r) (y r) (z r) (-t `dot` r) + (x u) (y u) (z u) (-t `dot` u) + (x f) (y f) (z f) (-t `dot` f) + 0 0 0 1 + + +-- | Invert the given matrix. +inverse :: Matrix4 -> Matrix4 +inverse mat = + let + a00 = m00 mat + a01 = m01 mat + a02 = m02 mat + a03 = m03 mat + a04 = m10 mat + a05 = m11 mat + a06 = m12 mat + a07 = m13 mat + a08 = m20 mat + a09 = m21 mat + a10 = m22 mat + a11 = m23 mat + a12 = m30 mat + a13 = m31 mat + a14 = m32 mat + a15 = m33 mat + + m00' = a05 * a10 * a15 + - a05 * a11 * a14 + - a09 * a06 * a15 + + a09 * a07 * a14 + + a13 * a06 * a11 + - a13 * a07 * a10 + + m04' = -a04 * a10 * a15 + + a04 * a11 * a14 + + a08 * a06 * a15 + - a08 * a07 * a14 + - a12 * a06 * a11 + + a12 * a07 * a10 + + m08' = a04 * a09 * a15 + - a04 * a11 * a13 + - a08 * a05 * a15 + + a08 * a07 * a13 + + a12 * a05 * a11 + - a12 * a07 * a09 + + m12' = -a04 * a09 * a14 + + a04 * a10 * a13 + + a08 * a05 * a14 + - a08 * a06 * a13 + - a12 * a05 * a10 + + a12 * a06 * a09 + + m01' = -a01 * a10 * a15 + + a01 * a11 * a14 + + a09 * a02 * a15 + - a09 * a03 * a14 + - a13 * a02 * a11 + + a13 * a03 * a10 + + m05' = a00 * a10 * a15 + - a00 * a11 * a14 + - a08 * a02 * a15 + + a08 * a03 * a14 + + a12 * a02 * a11 + - a12 * a03 * a10 + + m09' = -a00 * a09 * a15 + + a00 * a11 * a13 + + a08 * a01 * a15 + - a08 * a03 * a13 + - a12 * a01 * a11 + + a12 * a03 * a09 + + m13' = a00 * a09 * a14 + - a00 * a10 * a13 + - a08 * a01 * a14 + + a08 * a02 * a13 + + a12 * a01 * a10 + - a12 * a02 * a09 + + m02' = a01 * a06 * a15 + - a01 * a07 * a14 + - a05 * a02 * a15 + + a05 * a03 * a14 + + a13 * a02 * a07 + - a13 * a03 * a06 + + m06' = -a00 * a06 * a15 + + a00 * a07 * a14 + + a04 * a02 * a15 + - a04 * a03 * a14 + - a12 * a02 * a07 + + a12 * a03 * a06 + + m10' = a00 * a05 * a15 + - a00 * a07 * a13 + - a04 * a01 * a15 + + a04 * a03 * a13 + + a12 * a01 * a07 + - a12 * a03 * a05 + + m14' = -a00 * a05 * a14 + + a00 * a06 * a13 + + a04 * a01 * a14 + - a04 * a02 * a13 + - a12 * a01 * a06 + + a12 * a02 * a05 + + m03' = -a01 * a06 * a11 + + a01 * a07 * a10 + + a05 * a02 * a11 + - a05 * a03 * a10 + - a09 * a02 * a07 + + a09 * a03 * a06 + + m07' = a00 * a06 * a11 + - a00 * a07 * a10 + - a04 * a02 * a11 + + a04 * a03 * a10 + + a08 * a02 * a07 + - a08 * a03 * a06 + + m11' = -a00 * a05 * a11 + + a00 * a07 * a09 + + a04 * a01 * a11 + - a04 * a03 * a09 + - a08 * a01 * a07 + + a08 * a03 * a05 + + m15' = a00 * a05 * a10 + - a00 * a06 * a09 + - a04 * a01 * a10 + + a04 * a02 * a09 + + a08 * a01 * a06 + - a08 * a02 * a05 + + det' = a00 * m00' + a01 * m04' + a02 * m08' + a03 * m12' + in + if det' == 0 then Spear.Math.Matrix4.id + else + let det = 1 / det' + in mat4 + (m00' * det) (m04' * det) (m08' * det) (m12' * det) + (m01' * det) (m05' * det) (m09' * det) (m13' * det) + (m02' * det) (m06' * det) (m10' * det) (m14' * det) + (m03' * det) (m07' * det) (m11' * det) (m15' * det) + + +-- | Transform the given vector in 3D space with the given matrix. +mul :: Float -> Matrix4 -> Vector3 -> Vector3 +mul w m v = vec3 x' y' z' + where + v' = vec4 (x v) (y v) (z v) w + x' = row0 m `dot` v' + y' = row1 m `dot` v' + z' = row2 m `dot` v' + + +-- | Transform the given point vector in 3D space with the given matrix. +mulp :: Matrix4 -> Vector3 -> Vector3 +mulp = mul 1 + + +-- | Transform the given directional vector in 3D space with the given matrix. +muld :: Matrix4 -> Vector3 -> Vector3 +muld = mul 0 + + +-- | Transform the given vector with the given matrix. +-- +-- The vector is brought from homogeneous space to 3D space by performing a +-- perspective divide. +mul' :: Float -> Matrix4 -> Vector3 -> Vector3 +mul' w m v = vec3 (x'/w') (y'/w') (z'/w') + where + v' = vec4 (x v) (y v) (z v) w + x' = row0 m `dot` v' + y' = row1 m `dot` v' + z' = row2 m `dot` v' + w' = row3 m `dot` v' + + +toRAD = (*pi) . (/180) diff --git a/Spear/Math/MatrixUtils.hs b/Spear/Math/MatrixUtils.hs index e4273a1..24d9778 100644 --- a/Spear/Math/MatrixUtils.hs +++ b/Spear/Math/MatrixUtils.hs @@ -1,150 +1,150 @@ -module Spear.Math.MatrixUtils -( - fastNormalMatrix -, unproject -, rpgUnproject -, rpgTransform -, pltTransform -, rpgInverse -, pltInverse -, objToClip -) -where - - -import Spear.Math.Camera as Cam -import Spear.Math.Matrix3 as M3 -import Spear.Math.Matrix4 as M4 -import Spear.Math.Spatial3 as S -import Spear.Math.Vector as V - - --- | Compute the normal matrix of the given matrix. -fastNormalMatrix :: Matrix4 -> Matrix3 -fastNormalMatrix m = - let m' = M4.transpose . M4.inverseTransform $ m - in M3.mat3 - (M4.m00 m') (M4.m10 m') (M4.m20 m') - (M4.m01 m') (M4.m11 m') (M4.m21 m') - (M4.m02 m') (M4.m12 m') (M4.m22 m') - - --- | Transform the given point in window coordinates to object coordinates. -unproject :: Matrix4 -- ^ Inverse projection matrix - -> Matrix4 -- ^ Inverse modelview matrix. - -> Float -- ^ Viewport x - -> Float -- ^ Viewport y - -> Float -- ^ Viewport width - -> Float -- ^ Viewport height - -> Float -- ^ Window x - -> Float -- ^ Window y - -> Float -- ^ Window z - -> Vector3 -unproject projI modelviewI vpx vpy w h x y z = - let - xmouse = 2*(x-vpx)/w - 1 - ymouse = 2*(y-vpy)/h - 1 - zmouse = 2*z - 1 - in - (modelviewI * projI) `M4.mulp` vec3 xmouse ymouse zmouse - - --- | Transform the given point in window coordinates to 2d coordinates. --- --- The line defined by the given point in window space is intersected with --- the XZ plane in world space to yield the resulting 2d point. -rpgUnproject - :: Matrix4 -- ^ Inverse projection matrix - -> Matrix4 -- ^ Inverse viewI matrix. - -> Float -- ^ Viewport x - -> Float -- ^ Viewport y - -> Float -- ^ Viewport width - -> Float -- ^ Viewport height - -> Float -- ^ Window x - -> Float -- ^ Window y - -> Vector2 -rpgUnproject projI viewI vpx vpy w h wx wy = - let - p1 = unproject projI viewI vpx vpy w h wx wy 0 - p2 = unproject projI viewI vpx vpy w h wx wy (-1) - lambda = (y p1 / (y p1 - y p2)) - p' = p1 + V.scale lambda (p2 - p1) - in - vec2 (x p') (-(z p')) - - --- | Map an object's transform in view space to world space. -rpgTransform - :: Float -- ^ The height above the ground - -> Float -- ^ Angle of rotation - -> Vector3 -- ^ Axis of rotation - -> Vector2 -- ^ Object's position - -> Matrix4 -- ^ Inverse view matrix - -> Matrix4 -rpgTransform h a axis pos viewI = - let p1 = viewI `M4.mulp` (vec3 (x pos) (y pos) 0) - p2 = viewI `M4.mulp` (vec3 (x pos) (y pos) (-1)) - lambda = (y p1 / (y p1 - y p2)) - p = p1 + V.scale lambda (p2 - p1) - mat' = axisAngle axis a - r = M4.right mat' - u = M4.up mat' - f = M4.forward mat' - t = p + vec3 0 h 0 - in mat4 - (x r) (x u) (x f) (x t) - (y r) (y u) (y f) (y t) - (z r) (z u) (z f) (z t) - 0 0 0 1 - - --- | Map an object's transform in view space to world space. -pltTransform :: Matrix3 -> Matrix4 -pltTransform mat = - let r = let r' = M3.right mat in vec3 (x r') (y r') 0 - u = let u' = M3.up mat in vec3 (x u') (y u') 0 - f = unitz3 - t = let t' = M3.position mat in vec3 (x t') (y t') 0 - in mat4 - (x r) (x u) (x f) (x t) - (y r) (y u) (y f) (y t) - (z r) (z u) (z f) (z t) - 0 0 0 1 - - --- | Map an object's transform in world space to view space. --- --- The XY plane in 2D translates to the X(-Z) plane in 3D. --- --- Use this in games such as RPGs and RTSs. -rpgInverse - :: Float -- ^ The height above the ground - -> Float -- ^ Angle of rotation - -> Vector3 -- ^ Axis of rotation - -> Vector2 -- ^ Object's position - -> Matrix4 -- ^ Inverse view matrix - -> Matrix4 -rpgInverse h a axis pos viewI = - M4.inverseTransform $ rpgTransform h a axis pos viewI - - --- | Map an object's transform in world space to view space. --- --- This function maps an object's transform in 2D to the object's inverse in 3D. --- --- The XY plane in 2D translates to the XY plane in 3D. --- --- Use this in games like platformers and space invaders style games. -pltInverse :: Matrix3 -> Matrix4 -pltInverse = M4.inverseTransform . pltTransform - - --- | Transform an object from object to clip space coordinates. -objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 -objToClip cam model p = - let - view = M4.inverseTransform $ S.transform cam - proj = Cam.projection cam - p' = (proj * view * model) `M4.mulp` p - in - vec2 (x p') (y p') +module Spear.Math.MatrixUtils +( + fastNormalMatrix +, unproject +, rpgUnproject +, rpgTransform +, pltTransform +, rpgInverse +, pltInverse +, objToClip +) +where + + +import Spear.Math.Camera as Cam +import Spear.Math.Matrix3 as M3 +import Spear.Math.Matrix4 as M4 +import Spear.Math.Spatial3 as S +import Spear.Math.Vector as V + + +-- | Compute the normal matrix of the given matrix. +fastNormalMatrix :: Matrix4 -> Matrix3 +fastNormalMatrix m = + let m' = M4.transpose . M4.inverseTransform $ m + in M3.mat3 + (M4.m00 m') (M4.m10 m') (M4.m20 m') + (M4.m01 m') (M4.m11 m') (M4.m21 m') + (M4.m02 m') (M4.m12 m') (M4.m22 m') + + +-- | Transform the given point in window coordinates to object coordinates. +unproject :: Matrix4 -- ^ Inverse projection matrix + -> Matrix4 -- ^ Inverse modelview matrix. + -> Float -- ^ Viewport x + -> Float -- ^ Viewport y + -> Float -- ^ Viewport width + -> Float -- ^ Viewport height + -> Float -- ^ Window x + -> Float -- ^ Window y + -> Float -- ^ Window z + -> Vector3 +unproject projI modelviewI vpx vpy w h x y z = + let + xmouse = 2*(x-vpx)/w - 1 + ymouse = 2*(y-vpy)/h - 1 + zmouse = 2*z - 1 + in + (modelviewI * projI) `M4.mulp` vec3 xmouse ymouse zmouse + + +-- | Transform the given point in window coordinates to 2d coordinates. +-- +-- The line defined by the given point in window space is intersected with +-- the XZ plane in world space to yield the resulting 2d point. +rpgUnproject + :: Matrix4 -- ^ Inverse projection matrix + -> Matrix4 -- ^ Inverse viewI matrix. + -> Float -- ^ Viewport x + -> Float -- ^ Viewport y + -> Float -- ^ Viewport width + -> Float -- ^ Viewport height + -> Float -- ^ Window x + -> Float -- ^ Window y + -> Vector2 +rpgUnproject projI viewI vpx vpy w h wx wy = + let + p1 = unproject projI viewI vpx vpy w h wx wy 0 + p2 = unproject projI viewI vpx vpy w h wx wy (-1) + lambda = (y p1 / (y p1 - y p2)) + p' = p1 + V.scale lambda (p2 - p1) + in + vec2 (x p') (-(z p')) + + +-- | Map an object's transform in view space to world space. +rpgTransform + :: Float -- ^ The height above the ground + -> Float -- ^ Angle of rotation + -> Vector3 -- ^ Axis of rotation + -> Vector2 -- ^ Object's position + -> Matrix4 -- ^ Inverse view matrix + -> Matrix4 +rpgTransform h a axis pos viewI = + let p1 = viewI `M4.mulp` (vec3 (x pos) (y pos) 0) + p2 = viewI `M4.mulp` (vec3 (x pos) (y pos) (-1)) + lambda = (y p1 / (y p1 - y p2)) + p = p1 + V.scale lambda (p2 - p1) + mat' = axisAngle axis a + r = M4.right mat' + u = M4.up mat' + f = M4.forward mat' + t = p + vec3 0 h 0 + in mat4 + (x r) (x u) (x f) (x t) + (y r) (y u) (y f) (y t) + (z r) (z u) (z f) (z t) + 0 0 0 1 + + +-- | Map an object's transform in view space to world space. +pltTransform :: Matrix3 -> Matrix4 +pltTransform mat = + let r = let r' = M3.right mat in vec3 (x r') (y r') 0 + u = let u' = M3.up mat in vec3 (x u') (y u') 0 + f = unitz3 + t = let t' = M3.position mat in vec3 (x t') (y t') 0 + in mat4 + (x r) (x u) (x f) (x t) + (y r) (y u) (y f) (y t) + (z r) (z u) (z f) (z t) + 0 0 0 1 + + +-- | Map an object's transform in world space to view space. +-- +-- The XY plane in 2D translates to the X(-Z) plane in 3D. +-- +-- Use this in games such as RPGs and RTSs. +rpgInverse + :: Float -- ^ The height above the ground + -> Float -- ^ Angle of rotation + -> Vector3 -- ^ Axis of rotation + -> Vector2 -- ^ Object's position + -> Matrix4 -- ^ Inverse view matrix + -> Matrix4 +rpgInverse h a axis pos viewI = + M4.inverseTransform $ rpgTransform h a axis pos viewI + + +-- | Map an object's transform in world space to view space. +-- +-- This function maps an object's transform in 2D to the object's inverse in 3D. +-- +-- The XY plane in 2D translates to the XY plane in 3D. +-- +-- Use this in games like platformers and space invaders style games. +pltInverse :: Matrix3 -> Matrix4 +pltInverse = M4.inverseTransform . pltTransform + + +-- | Transform an object from object to clip space coordinates. +objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 +objToClip cam model p = + let + view = M4.inverseTransform $ S.transform cam + proj = Cam.projection cam + p' = (proj * view * model) `M4.mulp` p + in + 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 @@ -module Spear.Math.Octree -( - Octree -, makeOctree -, clone -, Spear.Math.Octree.insert -, Spear.Math.Octree.map -, gmap -) -where - -import Spear.Math.AABB -import Spear.Math.Collision -import Spear.Math.Vector - -import Control.Applicative ((<*>)) -import Data.List -import Data.Functor -import Data.Monoid -import qualified Data.Foldable as F - --- | An octree. -data Octree e - = Octree - { root :: !AABB2 - , ents :: ![e] - , c1 :: !(Octree e) - , c2 :: !(Octree e) - , c3 :: !(Octree e) - , c4 :: !(Octree e) - , c5 :: !(Octree e) - , c6 :: !(Octree e) - , c7 :: !(Octree e) - , c8 :: !(Octree e) - } - | - Leaf - { root :: !AABB2 - , ents :: ![e] - } - --- | Construct an octree using the specified AABB as the root and having the specified depth. -makeOctree :: Int -> AABB2 -> Octree e -makeOctree d root@(AABB2 min max) - | d == 0 = Leaf root [] - | otherwise = Octree root [] c1 c2 c3 c4 c5 c6 c7 c8 - where - boxes = subdivide root - c1 = makeOctree (d-1) $ boxes !! 0 - c2 = makeOctree (d-1) $ boxes !! 1 - c3 = makeOctree (d-1) $ boxes !! 2 - c4 = makeOctree (d-1) $ boxes !! 3 - c5 = makeOctree (d-1) $ boxes !! 4 - c6 = makeOctree (d-1) $ boxes !! 5 - c7 = makeOctree (d-1) $ boxes !! 6 - c8 = makeOctree (d-1) $ boxes !! 7 - -subdivide :: AABB2 -> [AABB2] -subdivide (AABB2 min max) = [a1, a2, a3, a4, a5, a6, a7, a8] - where - v = (max-min) / 2 - c = vec2 (x min + x v) (y min + y v) - a1 = AABB2 min c - a2 = AABB2 ( vec2 (x min) (y min)) ( vec2 (x c) (y c) ) - a3 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) - a4 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) - a5 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) - a6 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) - a7 = AABB2 ( vec2 (x c) (y c) ) ( vec2 (x max) (y max)) - a8 = AABB2 c max - --- | Clone the structure of the octree. The new octree has no entities. -clone :: Octree e -> Octree e -clone (Leaf root ents) = Leaf root [] -clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8' - where - c1' = clone c1 - c2' = clone c2 - c3' = clone c3 - c4' = clone c4 - c5' = clone c5 - c6' = clone c6 - c7' = clone c7 - c8' = clone c8 - -keep :: (e -> AABB2 -> CollisionType) -> AABB2 -> e -> Bool -keep testAABB2 aabb e = test == FullyContainedBy - where test = e `testAABB2` aabb - --- | Insert a list of entities into the octree. -insert :: (e -> AABB2 -> CollisionType) -> Octree e -> [e] -> Octree e -insert testAABB2 octree es = octree' where (octree', _) = insert' testAABB2 es octree - -insert' :: (e -> AABB2 -> CollisionType) -> [e] -> Octree e -> (Octree e, [e]) - -insert' testAABB2 es (Leaf root ents) = (Leaf root ents', outliers) - where - ents' = ents ++ ents_kept - ents_kept = filter (keep testAABB2 root) es - outliers = filter (not . keep testAABB2 root) es - -insert' testAABB2 es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (Octree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers) - where - ents' = ents ++ ents_kept - new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 - ents_kept = filter (keep testAABB2 root) new_ents - outliers = filter (not . keep testAABB2 root) new_ents - (c1', ents1) = insert' testAABB2 es c1 - (c2', ents2) = insert' testAABB2 es c2 - (c3', ents3) = insert' testAABB2 es c3 - (c4', ents4) = insert' testAABB2 es c4 - (c5', ents5) = insert' testAABB2 es c5 - (c6', ents6) = insert' testAABB2 es c6 - (c7', ents7) = insert' testAABB2 es c7 - (c8', ents8) = insert' testAABB2 es c8 - --- | Extract all entities from the octree. The resulting octree has no entities. -extract :: Octree e -> (Octree e, [e]) -extract (Leaf root ents) = (Leaf root [], ents) -extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents') - where - (c1', ents1) = extract c1 - (c2', ents2) = extract c2 - (c3', ents3) = extract c3 - (c4', ents4) = extract c4 - (c5', ents5) = extract c5 - (c6', ents6) = extract c6 - (c7', ents7) = extract c7 - (c8', ents8) = extract c8 - ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 - --- | Apply the given function to the entities in the octree. --- --- Entities that break out of their cell are reallocated appropriately. -map :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> Octree e -map testAABB2 f o = - let (o', outliers) = map' testAABB2 f o - in Spear.Math.Octree.insert testAABB2 o' outliers - -map' :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e]) - -map' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) - where - ents' = fmap f ents - ents_kept = filter (keep testAABB2 root) ents' - outliers = filter (not . keep testAABB2 root) ents' - -map' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) - where - ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 - ents_kept = filter (keep testAABB2 root) ents' - outliers = filter (not . keep testAABB2 root) ents' - (c1', out1) = map' testAABB2 f c1 - (c2', out2) = map' testAABB2 f c2 - (c3', out3) = map' testAABB2 f c3 - (c4', out4) = map' testAABB2 f c4 - (c5', out5) = map' testAABB2 f c5 - (c6', out6) = map' testAABB2 f c6 - (c7', out7) = map' testAABB2 f c7 - (c8', out8) = map' testAABB2 f c8 - - --- | Apply a function to the entity groups in the octree. --- --- Entities that break out of their cell are reallocated appropriately. -gmap :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e -gmap testAABB2 f o = - let (o', outliers) = gmap' testAABB2 f o - in Spear.Math.Octree.insert testAABB2 o' outliers - -gmap' :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e]) - -gmap' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) - where - ents' = f <$> ents <*> ents - ents_kept = filter (keep testAABB2 root) ents' - outliers = filter (not . keep testAABB2 root) ents' - -gmap' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) - where - ents'= (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 - ents_kept = filter (keep testAABB2 root) ents' - outliers = filter (not . keep testAABB2 root) ents' - (c1', out1) = gmap' testAABB2 f c1 - (c2', out2) = gmap' testAABB2 f c2 - (c3', out3) = gmap' testAABB2 f c3 - (c4', out4) = gmap' testAABB2 f c4 - (c5', out5) = gmap' testAABB2 f c5 - (c6', out6) = gmap' testAABB2 f c6 - (c7', out7) = gmap' testAABB2 f c7 - (c8', out8) = gmap' testAABB2 f c8 - -instance Functor Octree where - - fmap f (Leaf root ents) = Leaf root $ fmap f ents - - fmap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - Octree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8' - where - c1' = fmap f c1 - c2' = fmap f c2 - c3' = fmap f c3 - c4' = fmap f c4 - c5' = fmap f c5 - c6' = fmap f c6 - c7' = fmap f c7 - c8' = fmap f c8 - -instance F.Foldable Octree where - - foldMap f (Leaf root ents) = mconcat . fmap f $ ents - - foldMap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - mconcat (fmap f ents) `mappend` - c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend` - c5' `mappend` c6' `mappend` c7' `mappend` c8' - where - c1' = F.foldMap f c1 - c2' = F.foldMap f c2 - c3' = F.foldMap f c3 - c4' = F.foldMap f c4 - c5' = F.foldMap f c5 - c6' = F.foldMap f c6 - c7' = F.foldMap f c7 - c8' = F.foldMap f c8 +module Spear.Math.Octree +( + Octree +, makeOctree +, clone +, Spear.Math.Octree.insert +, Spear.Math.Octree.map +, gmap +) +where + +import Spear.Math.AABB +import Spear.Math.Collision +import Spear.Math.Vector + +import Control.Applicative ((<*>)) +import Data.List +import Data.Functor +import Data.Monoid +import qualified Data.Foldable as F + +-- | An octree. +data Octree e + = Octree + { root :: !AABB2 + , ents :: ![e] + , c1 :: !(Octree e) + , c2 :: !(Octree e) + , c3 :: !(Octree e) + , c4 :: !(Octree e) + , c5 :: !(Octree e) + , c6 :: !(Octree e) + , c7 :: !(Octree e) + , c8 :: !(Octree e) + } + | + Leaf + { root :: !AABB2 + , ents :: ![e] + } + +-- | Construct an octree using the specified AABB as the root and having the specified depth. +makeOctree :: Int -> AABB2 -> Octree e +makeOctree d root@(AABB2 min max) + | d == 0 = Leaf root [] + | otherwise = Octree root [] c1 c2 c3 c4 c5 c6 c7 c8 + where + boxes = subdivide root + c1 = makeOctree (d-1) $ boxes !! 0 + c2 = makeOctree (d-1) $ boxes !! 1 + c3 = makeOctree (d-1) $ boxes !! 2 + c4 = makeOctree (d-1) $ boxes !! 3 + c5 = makeOctree (d-1) $ boxes !! 4 + c6 = makeOctree (d-1) $ boxes !! 5 + c7 = makeOctree (d-1) $ boxes !! 6 + c8 = makeOctree (d-1) $ boxes !! 7 + +subdivide :: AABB2 -> [AABB2] +subdivide (AABB2 min max) = [a1, a2, a3, a4, a5, a6, a7, a8] + where + v = (max-min) / 2 + c = vec2 (x min + x v) (y min + y v) + a1 = AABB2 min c + a2 = AABB2 ( vec2 (x min) (y min)) ( vec2 (x c) (y c) ) + a3 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) + a4 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) + a5 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) + a6 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) + a7 = AABB2 ( vec2 (x c) (y c) ) ( vec2 (x max) (y max)) + a8 = AABB2 c max + +-- | Clone the structure of the octree. The new octree has no entities. +clone :: Octree e -> Octree e +clone (Leaf root ents) = Leaf root [] +clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8' + where + c1' = clone c1 + c2' = clone c2 + c3' = clone c3 + c4' = clone c4 + c5' = clone c5 + c6' = clone c6 + c7' = clone c7 + c8' = clone c8 + +keep :: (e -> AABB2 -> CollisionType) -> AABB2 -> e -> Bool +keep testAABB2 aabb e = test == FullyContainedBy + where test = e `testAABB2` aabb + +-- | Insert a list of entities into the octree. +insert :: (e -> AABB2 -> CollisionType) -> Octree e -> [e] -> Octree e +insert testAABB2 octree es = octree' where (octree', _) = insert' testAABB2 es octree + +insert' :: (e -> AABB2 -> CollisionType) -> [e] -> Octree e -> (Octree e, [e]) + +insert' testAABB2 es (Leaf root ents) = (Leaf root ents', outliers) + where + ents' = ents ++ ents_kept + ents_kept = filter (keep testAABB2 root) es + outliers = filter (not . keep testAABB2 root) es + +insert' testAABB2 es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + (Octree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers) + where + ents' = ents ++ ents_kept + new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 + ents_kept = filter (keep testAABB2 root) new_ents + outliers = filter (not . keep testAABB2 root) new_ents + (c1', ents1) = insert' testAABB2 es c1 + (c2', ents2) = insert' testAABB2 es c2 + (c3', ents3) = insert' testAABB2 es c3 + (c4', ents4) = insert' testAABB2 es c4 + (c5', ents5) = insert' testAABB2 es c5 + (c6', ents6) = insert' testAABB2 es c6 + (c7', ents7) = insert' testAABB2 es c7 + (c8', ents8) = insert' testAABB2 es c8 + +-- | Extract all entities from the octree. The resulting octree has no entities. +extract :: Octree e -> (Octree e, [e]) +extract (Leaf root ents) = (Leaf root [], ents) +extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents') + where + (c1', ents1) = extract c1 + (c2', ents2) = extract c2 + (c3', ents3) = extract c3 + (c4', ents4) = extract c4 + (c5', ents5) = extract c5 + (c6', ents6) = extract c6 + (c7', ents7) = extract c7 + (c8', ents8) = extract c8 + ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 + +-- | Apply the given function to the entities in the octree. +-- +-- Entities that break out of their cell are reallocated appropriately. +map :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> Octree e +map testAABB2 f o = + let (o', outliers) = map' testAABB2 f o + in Spear.Math.Octree.insert testAABB2 o' outliers + +map' :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e]) + +map' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) + where + ents' = fmap f ents + ents_kept = filter (keep testAABB2 root) ents' + outliers = filter (not . keep testAABB2 root) ents' + +map' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) + where + ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 + ents_kept = filter (keep testAABB2 root) ents' + outliers = filter (not . keep testAABB2 root) ents' + (c1', out1) = map' testAABB2 f c1 + (c2', out2) = map' testAABB2 f c2 + (c3', out3) = map' testAABB2 f c3 + (c4', out4) = map' testAABB2 f c4 + (c5', out5) = map' testAABB2 f c5 + (c6', out6) = map' testAABB2 f c6 + (c7', out7) = map' testAABB2 f c7 + (c8', out8) = map' testAABB2 f c8 + + +-- | Apply a function to the entity groups in the octree. +-- +-- Entities that break out of their cell are reallocated appropriately. +gmap :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e +gmap testAABB2 f o = + let (o', outliers) = gmap' testAABB2 f o + in Spear.Math.Octree.insert testAABB2 o' outliers + +gmap' :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e]) + +gmap' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers) + where + ents' = f <$> ents <*> ents + ents_kept = filter (keep testAABB2 root) ents' + outliers = filter (not . keep testAABB2 root) ents' + +gmap' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) + where + ents'= (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 + ents_kept = filter (keep testAABB2 root) ents' + outliers = filter (not . keep testAABB2 root) ents' + (c1', out1) = gmap' testAABB2 f c1 + (c2', out2) = gmap' testAABB2 f c2 + (c3', out3) = gmap' testAABB2 f c3 + (c4', out4) = gmap' testAABB2 f c4 + (c5', out5) = gmap' testAABB2 f c5 + (c6', out6) = gmap' testAABB2 f c6 + (c7', out7) = gmap' testAABB2 f c7 + (c8', out8) = gmap' testAABB2 f c8 + +instance Functor Octree where + + fmap f (Leaf root ents) = Leaf root $ fmap f ents + + fmap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + Octree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8' + where + c1' = fmap f c1 + c2' = fmap f c2 + c3' = fmap f c3 + c4' = fmap f c4 + c5' = fmap f c5 + c6' = fmap f c6 + c7' = fmap f c7 + c8' = fmap f c8 + +instance F.Foldable Octree where + + foldMap f (Leaf root ents) = mconcat . fmap f $ ents + + foldMap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + mconcat (fmap f ents) `mappend` + c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend` + c5' `mappend` c6' `mappend` c7' `mappend` c8' + where + c1' = F.foldMap f c1 + c2' = F.foldMap f c2 + c3' = F.foldMap f c3 + c4' = F.foldMap f c4 + c5' = F.foldMap f c5 + c6' = F.foldMap f c6 + c7' = F.foldMap f c7 + 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 @@ -module Spear.Math.Physics -( - module Spear.Math.Physics.Rigid -, module Spear.Math.Physics.Types -) -where - -import Spear.Math.Physics.Rigid -import Spear.Math.Physics.Types +module Spear.Math.Physics +( + module Spear.Math.Physics.Rigid +, module Spear.Math.Physics.Types +) +where + +import Spear.Math.Physics.Rigid +import Spear.Math.Physics.Types diff --git a/Spear/Math/Physics/Rigid.hs b/Spear/Math/Physics/Rigid.hs index 198385e..28995bd 100644 --- a/Spear/Math/Physics/Rigid.hs +++ b/Spear/Math/Physics/Rigid.hs @@ -1,125 +1,125 @@ -module Spear.Math.Physics.Rigid -( - module Spear.Math.Physics.Types -, RigidBody(..) -, rigidBody -, update -, setVelocity -, setAcceleration -) -where - -import qualified Spear.Math.Matrix3 as M3 -import Spear.Math.Spatial2 -import Spear.Math.Vector -import Spear.Physics.Types - -import Data.List (foldl') -import Control.Monad.State - -data RigidBody = RigidBody - { mass :: {-# UNPACK #-} !Float - , position :: {-# UNPACK #-} !Position - , velocity :: {-# UNPACK #-} !Velocity - , acceleration :: {-# UNPACK #-} !Acceleration - } - -instance Spatial2 RigidBody where - - move v body = body { position = v + position body } - - moveFwd speed body = body { position = position body + scale speed unity2 } - - moveBack speed body = body { position = position body + scale (-speed) unity2 } - - strafeLeft speed body = body { position = position body + scale (-speed) unitx2 } - - strafeRight speed body = body { position = position body + scale speed unitx2 } - - rotate angle = id - - setRotation angle = id - - pos = position - - fwd _ = unity2 - - up _ = unity2 - - right _ = unitx2 - - transform body = M3.transform unitx2 unity2 $ position body - - setTransform transf body = body { position = M3.position transf } - - setPos p body = body { position = p } - --- | Build a 'RigidBody'. -rigidBody :: Mass -> Position -> RigidBody -rigidBody m x = RigidBody m x zero2 zero2 - --- | Update the given 'RigidBody'. -update :: [Force] -> Dt -> RigidBody -> RigidBody -update forces dt body = - let netforce = foldl' (+) zero2 forces - m = mass body - r1 = position body - v1 = velocity body - a1 = acceleration body - r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1 - v' = v1 + scale (0.5*dt) a1 - a2 = a1 + scale (1/m) netforce - v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2 - in - RigidBody m r2 v2 a2 - --- | Set the body's velocity. -setVelocity :: Velocity -> RigidBody -> RigidBody -setVelocity v body = body { velocity = v } - --- | Set the body's acceleration. -setAcceleration :: Acceleration -> RigidBody -> RigidBody -setAcceleration a body = body { acceleration = a } - - --- test -{-gravity = vec2 0 (-10) -b0 = rigidBody 50 $ vec2 0 1000 - - -debug :: IO () -debug = evalStateT debug' b0 - - - -debug' :: StateT RigidBody IO () -debug' = do - lift . putStrLn $ "Initial body:" - lift . putStrLn . show' $ b0 - lift . putStrLn $ "Falling..." - step $ update [gravity*50] 1 - step $ update [gravity*50] 1 - step $ update [gravity*50] 1 - lift . putStrLn $ "Jumping" - step $ update [gravity*50, vec2 0 9000] 1 - lift . putStrLn $ "Falling..." - step $ update [gravity*50] 1 - step $ update [gravity*50] 1 - step $ update [gravity*50] 1 - - -step :: (RigidBody -> RigidBody) -> StateT RigidBody IO () -step update = do - modify update - body <- get - lift . putStrLn . show' $ body - - -show' body = - "mass " ++ (show $ mass body) ++ - ", position " ++ (showVec $ position body) ++ - ", velocity " ++ (showVec $ velocity body) ++ - ", acceleration " ++ (showVec $ acceleration body) - - -showVec v = (show $ x v) ++ ", " ++ (show $ y v)-} +module Spear.Math.Physics.Rigid +( + module Spear.Math.Physics.Types +, RigidBody(..) +, rigidBody +, update +, setVelocity +, setAcceleration +) +where + +import qualified Spear.Math.Matrix3 as M3 +import Spear.Math.Spatial2 +import Spear.Math.Vector +import Spear.Physics.Types + +import Data.List (foldl') +import Control.Monad.State + +data RigidBody = RigidBody + { mass :: {-# UNPACK #-} !Float + , position :: {-# UNPACK #-} !Position + , velocity :: {-# UNPACK #-} !Velocity + , acceleration :: {-# UNPACK #-} !Acceleration + } + +instance Spatial2 RigidBody where + + move v body = body { position = v + position body } + + moveFwd speed body = body { position = position body + scale speed unity2 } + + moveBack speed body = body { position = position body + scale (-speed) unity2 } + + strafeLeft speed body = body { position = position body + scale (-speed) unitx2 } + + strafeRight speed body = body { position = position body + scale speed unitx2 } + + rotate angle = id + + setRotation angle = id + + pos = position + + fwd _ = unity2 + + up _ = unity2 + + right _ = unitx2 + + transform body = M3.transform unitx2 unity2 $ position body + + setTransform transf body = body { position = M3.position transf } + + setPos p body = body { position = p } + +-- | Build a 'RigidBody'. +rigidBody :: Mass -> Position -> RigidBody +rigidBody m x = RigidBody m x zero2 zero2 + +-- | Update the given 'RigidBody'. +update :: [Force] -> Dt -> RigidBody -> RigidBody +update forces dt body = + let netforce = foldl' (+) zero2 forces + m = mass body + r1 = position body + v1 = velocity body + a1 = acceleration body + r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1 + v' = v1 + scale (0.5*dt) a1 + a2 = a1 + scale (1/m) netforce + v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2 + in + RigidBody m r2 v2 a2 + +-- | Set the body's velocity. +setVelocity :: Velocity -> RigidBody -> RigidBody +setVelocity v body = body { velocity = v } + +-- | Set the body's acceleration. +setAcceleration :: Acceleration -> RigidBody -> RigidBody +setAcceleration a body = body { acceleration = a } + + +-- test +{-gravity = vec2 0 (-10) +b0 = rigidBody 50 $ vec2 0 1000 + + +debug :: IO () +debug = evalStateT debug' b0 + + + +debug' :: StateT RigidBody IO () +debug' = do + lift . putStrLn $ "Initial body:" + lift . putStrLn . show' $ b0 + lift . putStrLn $ "Falling..." + step $ update [gravity*50] 1 + step $ update [gravity*50] 1 + step $ update [gravity*50] 1 + lift . putStrLn $ "Jumping" + step $ update [gravity*50, vec2 0 9000] 1 + lift . putStrLn $ "Falling..." + step $ update [gravity*50] 1 + step $ update [gravity*50] 1 + step $ update [gravity*50] 1 + + +step :: (RigidBody -> RigidBody) -> StateT RigidBody IO () +step update = do + modify update + body <- get + lift . putStrLn . show' $ body + + +show' body = + "mass " ++ (show $ mass body) ++ + ", position " ++ (showVec $ position body) ++ + ", velocity " ++ (showVec $ velocity body) ++ + ", acceleration " ++ (showVec $ acceleration body) + + +showVec v = (show $ x v) ++ ", " ++ (show $ y v)-} diff --git a/Spear/Math/Physics/Types.hs b/Spear/Math/Physics/Types.hs index 73cd90e..59e6c74 100644 --- a/Spear/Math/Physics/Types.hs +++ b/Spear/Math/Physics/Types.hs @@ -1,11 +1,11 @@ -module Spear.Math.Physics.Types -where - -import Spear.Math.Vector - -type Dt = Float -type Force = Vector2 -type Mass = Float -type Position = Vector2 -type Velocity = Vector2 -type Acceleration = Vector2 +module Spear.Math.Physics.Types +where + +import Spear.Math.Vector + +type Dt = Float +type Force = Vector2 +type Mass = Float +type Position = Vector2 +type Velocity = Vector2 +type Acceleration = Vector2 diff --git a/Spear/Math/Plane.hs b/Spear/Math/Plane.hs index 08e4570..ee788b5 100644 --- a/Spear/Math/Plane.hs +++ b/Spear/Math/Plane.hs @@ -1,39 +1,39 @@ -module Spear.Math.Plane -( - Plane -, plane -, classify -) -where - -import Spear.Math.Vector - -data PointPlanePos = Front | Back | Contained deriving (Eq, Show) - -data Plane = Plane - { n :: {-# UNPACK #-} !Vector3, - d :: {-# UNPACK #-} !Float - } - deriving(Eq, Show) - --- | Construct a plane from a normal vector and a distance from the origin. -plane :: Vector3 -> Float -> Plane -plane n d = Plane (normalise n) d - --- | Construct a plane from three points. --- --- Points must be given in counter-clockwise order. -fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane -fromPoints p0 p1 p2 = Plane n d - where n = normalise $ v1 `cross` v2 - v1 = p2 - p1 - v2 = p0 - p1 - d = p0 `dot` n - --- | Classify the given point's relative position with respect to the plane. -classify :: Plane -> Vector3 -> PointPlanePos -classify (Plane n d) pt = - case (n `dot` pt - d) `compare` 0 of - GT -> Front - LT -> Back - EQ -> Contained +module Spear.Math.Plane +( + Plane +, plane +, classify +) +where + +import Spear.Math.Vector + +data PointPlanePos = Front | Back | Contained deriving (Eq, Show) + +data Plane = Plane + { n :: {-# UNPACK #-} !Vector3, + d :: {-# UNPACK #-} !Float + } + deriving(Eq, Show) + +-- | Construct a plane from a normal vector and a distance from the origin. +plane :: Vector3 -> Float -> Plane +plane n d = Plane (normalise n) d + +-- | Construct a plane from three points. +-- +-- Points must be given in counter-clockwise order. +fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane +fromPoints p0 p1 p2 = Plane n d + where n = normalise $ v1 `cross` v2 + v1 = p2 - p1 + v2 = p0 - p1 + d = p0 `dot` n + +-- | Classify the given point's relative position with respect to the plane. +classify :: Plane -> Vector3 -> PointPlanePos +classify (Plane n d) pt = + case (n `dot` pt - d) `compare` 0 of + GT -> Front + LT -> Back + 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 @@ -module Spear.Math.Quaternion -( - Quaternion - -- * Construction -, quat -, qvec4 -, qvec3 -, qAxisAngle - -- * Operations -, qmul -, qconj -, qinv -, qnormalise -, qnorm -, qrot -) -where - - -import Spear.Math.Vector - - -newtype Quaternion = Quaternion { getVec :: Vector4 } - - --- | Build a 'Quaternion'. -quat :: Float -- x - -> Float -- y - -> Float -- z - -> Float -- w - -> Quaternion -quat x y z w = Quaternion $ vec4 x y z w - - --- | Build a 'Quaternion' from the given 'Vector4'. -qvec4 :: Vector4 -> Quaternion -qvec4 = Quaternion - - --- | Build a 'Quaternion' from the given 'Vector3' and w. -qvec3 :: Vector3 -> Float -> Quaternion -qvec3 v w = Quaternion $ vec4 (x v) (y v) (z v) w - - --- | Build a 'Quaternion' representing the given rotation. -qAxisAngle :: Vector3 -> Float -> Quaternion -qAxisAngle axis angle = - let s' = norm axis - s = if s' == 0 then 1 else s' - a = angle * toRAD * 0.5 - sa = sin a - qw = cos a - qx = x axis * sa * s - qy = y axis * sa * s - qz = z axis * sa * s - in - Quaternion $ vec4 qx qy qz qw - - --- | Compute the product of the given two quaternions. -qmul :: Quaternion -> Quaternion -> Quaternion -qmul (Quaternion q1) (Quaternion q2) = - let x1 = x q1 - y1 = y q1 - z1 = z q1 - w1 = w q1 - x2 = x q2 - y2 = y q2 - z2 = y q2 - w2 = w q2 - w' = w1*w2 - x1*x2 - y1*y2 - z1*z2 - x' = w1*x2 + x1*w2 + y1*z2 - z1*y2 - y' = w1*y2 - x1*z2 + y1*w2 + z1*x2 - z' = w1*z2 + x1*y2 - y1*x2 + z1*w2 - in - Quaternion $ vec4 x' y' z' w' - - --- | Compute the conjugate of the given 'Quaternion'. -qconj :: Quaternion -> Quaternion -qconj (Quaternion q) = Quaternion $ vec4 (-x q) (-y q) (-z q) (w q) - - --- | Invert the given 'Quaternion'. -qinv :: Quaternion -> Quaternion -qinv (Quaternion q) = - let m = normSq q - in Quaternion $ vec4 (-x q / m) (-y q / m) (-z q / m) (w q / m) - - --- | Normalise the given 'Quaternion'. -qnormalise :: Quaternion -> Quaternion -qnormalise = Quaternion . normalise . getVec - - --- | Compute the norm of the given 'Quaternion'. -qnorm :: Quaternion -> Float -qnorm = norm . getVec - - --- | Rotate the given 'Vector3'. -qrot :: Quaternion -> Vector3 -> Vector3 -qrot q v = toVec3 $ q `qmul` qvec3 v 0 `qmul` qconj q - where toVec3 (Quaternion q) = vec3 (x q) (y q) (z q) - - -toRAD = pi / 180 - +module Spear.Math.Quaternion +( + Quaternion + -- * Construction +, quat +, qvec4 +, qvec3 +, qAxisAngle + -- * Operations +, qmul +, qconj +, qinv +, qnormalise +, qnorm +, qrot +) +where + + +import Spear.Math.Vector + + +newtype Quaternion = Quaternion { getVec :: Vector4 } + + +-- | Build a 'Quaternion'. +quat :: Float -- x + -> Float -- y + -> Float -- z + -> Float -- w + -> Quaternion +quat x y z w = Quaternion $ vec4 x y z w + + +-- | Build a 'Quaternion' from the given 'Vector4'. +qvec4 :: Vector4 -> Quaternion +qvec4 = Quaternion + + +-- | Build a 'Quaternion' from the given 'Vector3' and w. +qvec3 :: Vector3 -> Float -> Quaternion +qvec3 v w = Quaternion $ vec4 (x v) (y v) (z v) w + + +-- | Build a 'Quaternion' representing the given rotation. +qAxisAngle :: Vector3 -> Float -> Quaternion +qAxisAngle axis angle = + let s' = norm axis + s = if s' == 0 then 1 else s' + a = angle * toRAD * 0.5 + sa = sin a + qw = cos a + qx = x axis * sa * s + qy = y axis * sa * s + qz = z axis * sa * s + in + Quaternion $ vec4 qx qy qz qw + + +-- | Compute the product of the given two quaternions. +qmul :: Quaternion -> Quaternion -> Quaternion +qmul (Quaternion q1) (Quaternion q2) = + let x1 = x q1 + y1 = y q1 + z1 = z q1 + w1 = w q1 + x2 = x q2 + y2 = y q2 + z2 = y q2 + w2 = w q2 + w' = w1*w2 - x1*x2 - y1*y2 - z1*z2 + x' = w1*x2 + x1*w2 + y1*z2 - z1*y2 + y' = w1*y2 - x1*z2 + y1*w2 + z1*x2 + z' = w1*z2 + x1*y2 - y1*x2 + z1*w2 + in + Quaternion $ vec4 x' y' z' w' + + +-- | Compute the conjugate of the given 'Quaternion'. +qconj :: Quaternion -> Quaternion +qconj (Quaternion q) = Quaternion $ vec4 (-x q) (-y q) (-z q) (w q) + + +-- | Invert the given 'Quaternion'. +qinv :: Quaternion -> Quaternion +qinv (Quaternion q) = + let m = normSq q + in Quaternion $ vec4 (-x q / m) (-y q / m) (-z q / m) (w q / m) + + +-- | Normalise the given 'Quaternion'. +qnormalise :: Quaternion -> Quaternion +qnormalise = Quaternion . normalise . getVec + + +-- | Compute the norm of the given 'Quaternion'. +qnorm :: Quaternion -> Float +qnorm = norm . getVec + + +-- | Rotate the given 'Vector3'. +qrot :: Quaternion -> Vector3 -> Vector3 +qrot q v = toVec3 $ q `qmul` qvec3 v 0 `qmul` qconj q + where toVec3 (Quaternion q) = vec3 (x q) (y q) (z q) + + +toRAD = pi / 180 + 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 @@ -module Spear.Math.Ray -( - Ray(..) -, raylr -, rayfb -) -where - - -import Spear.Math.Utils -import Spear.Math.Vector - - -data Ray = Ray - { origin :: {-# UNPACK #-} !Vector2 - , dir :: {-# UNPACK #-} !Vector2 - } - - --- | Classify the given point's position with respect to the given ray. Left/Right test. -raylr :: Ray -> Vector2 -> Side -raylr (Ray o d) p - | orientation2d o (o+d) p < 0 = R - | otherwise = L - - --- | Classify the given point's position with respect to the given ray. Front/Back test. -rayfb :: Ray -> Vector2 -> Face -rayfb (Ray o d) p - | orientation2d o (perp d) p > 0 = F - | otherwise = B +module Spear.Math.Ray +( + Ray(..) +, raylr +, rayfb +) +where + + +import Spear.Math.Utils +import Spear.Math.Vector + + +data Ray = Ray + { origin :: {-# UNPACK #-} !Vector2 + , dir :: {-# UNPACK #-} !Vector2 + } + + +-- | Classify the given point's position with respect to the given ray. Left/Right test. +raylr :: Ray -> Vector2 -> Side +raylr (Ray o d) p + | orientation2d o (o+d) p < 0 = R + | otherwise = L + + +-- | Classify the given point's position with respect to the given ray. Front/Back test. +rayfb :: Ray -> Vector2 -> Face +rayfb (Ray o d) p + | orientation2d o (perp d) p > 0 = F + | 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 @@ -module Spear.Math.Segment -( - Segment(..) -, seglr -) -where - - -import Spear.Math.Utils -import Spear.Math.Vector - - --- | A line segment in 2D space. -data Segment = Segment {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 - - --- | Classify the given point's position with respect to the given segment. -seglr :: Segment -> Vector2 -> Side -seglr (Segment p0 p1) p - | orientation2d p0 p1 p < 0 = R - | otherwise = L +module Spear.Math.Segment +( + Segment(..) +, seglr +) +where + + +import Spear.Math.Utils +import Spear.Math.Vector + + +-- | A line segment in 2D space. +data Segment = Segment {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 + + +-- | Classify the given point's position with respect to the given segment. +seglr :: Segment -> Vector2 -> Side +seglr (Segment p0 p1) p + | orientation2d p0 p1 p < 0 = R + | 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 @@ -module Spear.Math.Spatial2 -where - - -import Spear.Math.Vector -import Spear.Math.Matrix3 as M - - --- | An entity that can be moved around in 2D space. -class Spatial2 s where - - -- | Move the spatial. - move :: Vector2 -> s -> s - - -- | Move the spatial forwards. - moveFwd :: Float -> s -> s - - -- | Move the spatial backwards. - moveBack :: Float -> s -> s - - -- | Make the spatial strafe left. - strafeLeft :: Float -> s -> s - - -- | Make the spatial Strafe right. - strafeRight :: Float -> s -> s - - -- | Rotate the spatial. - rotate :: Float -> s -> s - - -- | Set the spatial's rotation. - setRotation :: Float -> s -> s - - -- | Get the spatial position. - pos :: s -> Vector2 - - -- | Get the spatial's forward vector. - fwd :: s -> Vector2 - - -- | Get the spatial's up vector. - up :: s -> Vector2 - - -- | Get the spatial's right vector. - right :: s -> Vector2 - - -- | Get the spatial's transform. - transform :: s -> Matrix3 - - -- | Set the spatial's transform. - setTransform :: Matrix3 -> s -> s - - -- | Set the spatial's position. - setPos :: Vector2 -> s -> s - - -- | Make the spatial look at the given point. - lookAt :: Vector2 -> s -> s - lookAt pt s = - let position = pos s - fwd = normalise $ pt - position - r = perp fwd - in - setTransform (M.transform r fwd position) s - - -- | Make the 'Spatial' orbit around the given point - orbit :: Vector2 -- ^ Target point - -> Float -- ^ Angle - -> Float -- ^ Orbit radius - -> s - -> s - - orbit pt angle radius s = - let a = angle * pi / 180 - px = (x pt) + radius * sin a - py = (y pt) + radius * cos a - in - setPos (vec2 px py) s +module Spear.Math.Spatial2 +where + + +import Spear.Math.Vector +import Spear.Math.Matrix3 as M + + +-- | An entity that can be moved around in 2D space. +class Spatial2 s where + + -- | Move the spatial. + move :: Vector2 -> s -> s + + -- | Move the spatial forwards. + moveFwd :: Float -> s -> s + + -- | Move the spatial backwards. + moveBack :: Float -> s -> s + + -- | Make the spatial strafe left. + strafeLeft :: Float -> s -> s + + -- | Make the spatial Strafe right. + strafeRight :: Float -> s -> s + + -- | Rotate the spatial. + rotate :: Float -> s -> s + + -- | Set the spatial's rotation. + setRotation :: Float -> s -> s + + -- | Get the spatial position. + pos :: s -> Vector2 + + -- | Get the spatial's forward vector. + fwd :: s -> Vector2 + + -- | Get the spatial's up vector. + up :: s -> Vector2 + + -- | Get the spatial's right vector. + right :: s -> Vector2 + + -- | Get the spatial's transform. + transform :: s -> Matrix3 + + -- | Set the spatial's transform. + setTransform :: Matrix3 -> s -> s + + -- | Set the spatial's position. + setPos :: Vector2 -> s -> s + + -- | Make the spatial look at the given point. + lookAt :: Vector2 -> s -> s + lookAt pt s = + let position = pos s + fwd = normalise $ pt - position + r = perp fwd + in + setTransform (M.transform r fwd position) s + + -- | Make the 'Spatial' orbit around the given point + orbit :: Vector2 -- ^ Target point + -> Float -- ^ Angle + -> Float -- ^ Orbit radius + -> s + -> s + + orbit pt angle radius s = + let a = angle * pi / 180 + px = (x pt) + radius * sin a + py = (y pt) + radius * cos a + in + 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 @@ -module Spear.Math.Spatial3 -( - Spatial3(..) -, Obj3 -, fromVectors -, fromTransform -) -where - -import Spear.Math.Vector -import qualified Spear.Math.Matrix4 as M - -type Matrix4 = M.Matrix4 - -class Spatial3 s where - -- | Gets the spatial's internal Obj3. - getObj3 :: s -> Obj3 - - -- | Set the spatial's internal Obj3. - setObj3 :: s -> Obj3 -> s - - -- | Move the spatial. - move :: Vector3 -> s -> s - move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } - - -- | Move the spatial forwards. - moveFwd :: Float -> s -> s - moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } - - -- | Move the spatial backwards. - moveBack :: Float -> s -> s - moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } - - -- | Make the spatial strafe left. - strafeLeft :: Float -> s -> s - strafeLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } - - -- | Make the spatial Strafe right. - strafeRight :: Float -> s -> s - strafeRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } - - -- | Rotate the spatial about the given axis. - rotate :: Vector3 -> Float -> s -> s - rotate axis a s = - let t = transform s - axis' = M.inverseTransform t `M.muld` axis - in setTransform (t * M.axisAngle axis' a) s - - -- | Rotate the spatial about its local X axis. - pitch :: Float -> s -> s - pitch a s = - let o = getObj3 s - a' = toRAD a - sa = sin a' - ca = cos a' - f' = normalise $ scale ca (f o) + scale sa (u o) - u' = normalise $ r o `cross` f' - in setObj3 s $ o { u = u', f = f' } - - -- | Rotate the spatial about its local Y axis. - yaw :: Float -> s -> s - yaw a s = - let o = getObj3 s - a' = toRAD a - sa = sin a' - ca = cos a' - r' = normalise $ scale ca (r o) + scale sa (f o) - f' = normalise $ u o `cross` r' - in setObj3 s $ o { r = r', f = f' } - - -- | Rotate the spatial about its local Z axis. - roll :: Float -> s -> s - roll a s = - let o = getObj3 s - a' = toRAD a - sa = sin a' - ca = cos a' - u' = normalise $ scale ca (u o) - scale sa (r o) - r' = normalise $ f o `cross` u' - in setObj3 s $ o { r = r', u = u' } - - -- | Get the spatial's position. - pos :: s -> Vector3 - pos = p . getObj3 - - -- | Get the spatial's forward vector. - fwd :: s -> Vector3 - fwd = f . getObj3 - - -- | Get the spatial's up vector. - up :: s -> Vector3 - up = u . getObj3 - - -- | Get the spatial's right vector. - right :: s -> Vector3 - right = r . getObj3 - - -- | Get the spatial's transform. - transform :: s -> Matrix4 - transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) - - -- | Set the spatial's transform. - setTransform :: Matrix4 -> s -> s - setTransform t s = - let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) - in setObj3 s o - - -- | Set the spatial's position. - setPos :: Vector3 -> s -> s - setPos pos s = setObj3 s $ (getObj3 s) { p = pos } - - -- | Make the spatial look at the given point. - lookAt :: Vector3 -> s -> s - lookAt pt s = - let position = pos s - fwd = normalise $ pt - position - r = fwd `cross` unity3 - u = r `cross` fwd - in - setTransform (M.transform r u (-fwd) position) s - - -- | Make the spatial orbit around the given point - orbit :: Vector3 -- ^ Target point - -> Float -- ^ Horizontal angle - -> Float -- ^ Vertical angle - -> Float -- ^ Orbit radius. - -> s - -> s - - orbit pt anglex angley radius s = - let ax = anglex * pi / 180 - ay = angley * pi / 180 - sx = sin ax - sy = sin ay - cx = cos ax - cy = cos ay - px = (x pt) + radius*cy*sx - py = (y pt) + radius*sy - pz = (z pt) + radius*cx*cy - in - setPos (vec3 px py pz) s - --- | An object in 3D space. -data Obj3 = Obj3 - { r :: Vector3 - , u :: Vector3 - , f :: Vector3 - , p :: Vector3 - } deriving Show - -instance Spatial3 Obj3 where - getObj3 = id - setObj3 _ o' = o' - -fromVectors :: Right3 -> Up3 -> Forward3 -> Position3 -> Obj3 -fromVectors = Obj3 - -fromTransform :: Matrix4 -> Obj3 -fromTransform m = Obj3 (M.right m) (M.up m) (M.forward m) (M.position m) - -toRAD = (*pi) . (/180) +module Spear.Math.Spatial3 +( + Spatial3(..) +, Obj3 +, fromVectors +, fromTransform +) +where + +import Spear.Math.Vector +import qualified Spear.Math.Matrix4 as M + +type Matrix4 = M.Matrix4 + +class Spatial3 s where + -- | Gets the spatial's internal Obj3. + getObj3 :: s -> Obj3 + + -- | Set the spatial's internal Obj3. + setObj3 :: s -> Obj3 -> s + + -- | Move the spatial. + move :: Vector3 -> s -> s + move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } + + -- | Move the spatial forwards. + moveFwd :: Float -> s -> s + moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } + + -- | Move the spatial backwards. + moveBack :: Float -> s -> s + moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } + + -- | Make the spatial strafe left. + strafeLeft :: Float -> s -> s + strafeLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } + + -- | Make the spatial Strafe right. + strafeRight :: Float -> s -> s + strafeRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } + + -- | Rotate the spatial about the given axis. + rotate :: Vector3 -> Float -> s -> s + rotate axis a s = + let t = transform s + axis' = M.inverseTransform t `M.muld` axis + in setTransform (t * M.axisAngle axis' a) s + + -- | Rotate the spatial about its local X axis. + pitch :: Float -> s -> s + pitch a s = + let o = getObj3 s + a' = toRAD a + sa = sin a' + ca = cos a' + f' = normalise $ scale ca (f o) + scale sa (u o) + u' = normalise $ r o `cross` f' + in setObj3 s $ o { u = u', f = f' } + + -- | Rotate the spatial about its local Y axis. + yaw :: Float -> s -> s + yaw a s = + let o = getObj3 s + a' = toRAD a + sa = sin a' + ca = cos a' + r' = normalise $ scale ca (r o) + scale sa (f o) + f' = normalise $ u o `cross` r' + in setObj3 s $ o { r = r', f = f' } + + -- | Rotate the spatial about its local Z axis. + roll :: Float -> s -> s + roll a s = + let o = getObj3 s + a' = toRAD a + sa = sin a' + ca = cos a' + u' = normalise $ scale ca (u o) - scale sa (r o) + r' = normalise $ f o `cross` u' + in setObj3 s $ o { r = r', u = u' } + + -- | Get the spatial's position. + pos :: s -> Vector3 + pos = p . getObj3 + + -- | Get the spatial's forward vector. + fwd :: s -> Vector3 + fwd = f . getObj3 + + -- | Get the spatial's up vector. + up :: s -> Vector3 + up = u . getObj3 + + -- | Get the spatial's right vector. + right :: s -> Vector3 + right = r . getObj3 + + -- | Get the spatial's transform. + transform :: s -> Matrix4 + transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) + + -- | Set the spatial's transform. + setTransform :: Matrix4 -> s -> s + setTransform t s = + let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) + in setObj3 s o + + -- | Set the spatial's position. + setPos :: Vector3 -> s -> s + setPos pos s = setObj3 s $ (getObj3 s) { p = pos } + + -- | Make the spatial look at the given point. + lookAt :: Vector3 -> s -> s + lookAt pt s = + let position = pos s + fwd = normalise $ pt - position + r = fwd `cross` unity3 + u = r `cross` fwd + in + setTransform (M.transform r u (-fwd) position) s + + -- | Make the spatial orbit around the given point + orbit :: Vector3 -- ^ Target point + -> Float -- ^ Horizontal angle + -> Float -- ^ Vertical angle + -> Float -- ^ Orbit radius. + -> s + -> s + + orbit pt anglex angley radius s = + let ax = anglex * pi / 180 + ay = angley * pi / 180 + sx = sin ax + sy = sin ay + cx = cos ax + cy = cos ay + px = (x pt) + radius*cy*sx + py = (y pt) + radius*sy + pz = (z pt) + radius*cx*cy + in + setPos (vec3 px py pz) s + +-- | An object in 3D space. +data Obj3 = Obj3 + { r :: Vector3 + , u :: Vector3 + , f :: Vector3 + , p :: Vector3 + } deriving Show + +instance Spatial3 Obj3 where + getObj3 = id + setObj3 _ o' = o' + +fromVectors :: Right3 -> Up3 -> Forward3 -> Position3 -> Obj3 +fromVectors = Obj3 + +fromTransform :: Matrix4 -> Obj3 +fromTransform m = Obj3 (M.right m) (M.up m) (M.forward m) (M.position m) + +toRAD = (*pi) . (/180) diff --git a/Spear/Math/Sphere.hs b/Spear/Math/Sphere.hs index 9c80811..197a9b2 100644 --- a/Spear/Math/Sphere.hs +++ b/Spear/Math/Sphere.hs @@ -1,26 +1,26 @@ -module Spear.Math.Sphere -where - -import Spear.Math.Vector - -import Data.List (foldl') - --- | A sphere in 3D space. -data Sphere = Sphere - { center :: {-# UNPACK #-} !Vector3 - , radius :: {-# UNPACK #-} !Float - } - --- | Create a sphere from the given points. -sphere :: [Vector3] -> Sphere -sphere [] = Sphere zero3 0 -sphere (x:xs) = Sphere c r - where - c = pmin + (pmax-pmin)/2 - r = norm $ pmax - c - (pmin,pmax) = foldl' update (x,x) xs - update (pmin,pmax) p = (min p pmin, max p pmax) - --- | Return 'True' if the given sphere contains the given point, 'False' otherwise. -circlept :: Sphere -> Vector3 -> Bool -circlept (Sphere c r) p = r*r >= normSq (p - c) +module Spear.Math.Sphere +where + +import Spear.Math.Vector + +import Data.List (foldl') + +-- | A sphere in 3D space. +data Sphere = Sphere + { center :: {-# UNPACK #-} !Vector3 + , radius :: {-# UNPACK #-} !Float + } + +-- | Create a sphere from the given points. +sphere :: [Vector3] -> Sphere +sphere [] = Sphere zero3 0 +sphere (x:xs) = Sphere c r + where + c = pmin + (pmax-pmin)/2 + r = norm $ pmax - c + (pmin,pmax) = foldl' update (x,x) xs + update (pmin,pmax) p = (min p pmin, max p pmax) + +-- | Return 'True' if the given sphere contains the given point, 'False' otherwise. +circlept :: Sphere -> Vector3 -> Bool +circlept (Sphere c r) p = r*r >= normSq (p - c) diff --git a/Spear/Math/Triangle.hs b/Spear/Math/Triangle.hs index 96cfa1a..04c2639 100644 --- a/Spear/Math/Triangle.hs +++ b/Spear/Math/Triangle.hs @@ -1,40 +1,40 @@ -module Spear.Math.Triangle -( - Triangle(..) -) -where - - -import Spear.Math.Vector - -import Foreign.C.Types -import Foreign.Storable - - -data Triangle = Triangle - { p0 :: {-# UNPACK #-} !Vector3 - , p1 :: {-# UNPACK #-} !Vector3 - , p2 :: {-# UNPACK #-} !Vector3 - } - - -sizeVector3 = 3 * sizeOf (undefined :: CFloat) - - -instance Storable Triangle where - - sizeOf _ = 3 * sizeVector3 - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - p0 <- peekByteOff ptr 0 - p1 <- peekByteOff ptr $ 1 * sizeVector3 - p2 <- peekByteOff ptr $ 2 * sizeVector3 - - return $ Triangle p0 p1 p2 - - - poke ptr (Triangle p0 p1 p2) = do - pokeByteOff ptr 0 p0 - pokeByteOff ptr (1*sizeVector3) p1 - pokeByteOff ptr (2*sizeVector3) p2 +module Spear.Math.Triangle +( + Triangle(..) +) +where + + +import Spear.Math.Vector + +import Foreign.C.Types +import Foreign.Storable + + +data Triangle = Triangle + { p0 :: {-# UNPACK #-} !Vector3 + , p1 :: {-# UNPACK #-} !Vector3 + , p2 :: {-# UNPACK #-} !Vector3 + } + + +sizeVector3 = 3 * sizeOf (undefined :: CFloat) + + +instance Storable Triangle where + + sizeOf _ = 3 * sizeVector3 + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + p0 <- peekByteOff ptr 0 + p1 <- peekByteOff ptr $ 1 * sizeVector3 + p2 <- peekByteOff ptr $ 2 * sizeVector3 + + return $ Triangle p0 p1 p2 + + + poke ptr (Triangle p0 p1 p2) = do + pokeByteOff ptr 0 p0 + pokeByteOff ptr (1*sizeVector3) p1 + 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 @@ -module Spear.Math.Utils -( - Side(..) -, Face(..) -, orientation2d -, viewToWorld2d -) -where - - -import Spear.Math.Matrix4 as M4 -import Spear.Math.Vector as V - - -data Side = L | R deriving (Eq, Show) - - -data Face = F | B deriving (Eq, Show) - - --- | Return the signed area of the triangle defined by the given points. -orientation2d :: Vector2 -> Vector2 -> Vector2 -> Float -orientation2d p q r = (x q - x p) * (y r - y p) - (y q - y p) * (x r - x p) - - --- | Project the given point in view space onto the XZ plane in world space. -viewToWorld2d :: Vector2 -- ^ Point in view space - -> Matrix4 -- ^ Inverse view matrix - -> Vector2 -- ^ Projection of the given point -viewToWorld2d p viewI = - let - p1' = vec3 (x p) (y p) 0 - p1 = viewI `mulp` p1' - p2 = p1 - M4.forward viewI - lambda = (y p1 / (y p1 - y p2)) - p' = p1 + V.scale lambda (p2 - p1) - in - vec2 (x p') (-z p') +module Spear.Math.Utils +( + Side(..) +, Face(..) +, orientation2d +, viewToWorld2d +) +where + + +import Spear.Math.Matrix4 as M4 +import Spear.Math.Vector as V + + +data Side = L | R deriving (Eq, Show) + + +data Face = F | B deriving (Eq, Show) + + +-- | Return the signed area of the triangle defined by the given points. +orientation2d :: Vector2 -> Vector2 -> Vector2 -> Float +orientation2d p q r = (x q - x p) * (y r - y p) - (y q - y p) * (x r - x p) + + +-- | Project the given point in view space onto the XZ plane in world space. +viewToWorld2d :: Vector2 -- ^ Point in view space + -> Matrix4 -- ^ Inverse view matrix + -> Vector2 -- ^ Projection of the given point +viewToWorld2d p viewI = + let + p1' = vec3 (x p) (y p) 0 + p1 = viewI `mulp` p1' + p2 = p1 - M4.forward viewI + lambda = (y p1 / (y p1 - y p2)) + p' = p1 + V.scale lambda (p2 - p1) + in + 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 @@ -module Spear.Math.Vector -( - module Spear.Math.Vector.Vector2 -, module Spear.Math.Vector.Vector3 -, module Spear.Math.Vector.Vector4 -, module Spear.Math.Vector.Class -) -where - -import Spear.Math.Vector.Vector2 -import Spear.Math.Vector.Vector3 -import Spear.Math.Vector.Vector4 -import Spear.Math.Vector.Class +module Spear.Math.Vector +( + module Spear.Math.Vector.Vector2 +, module Spear.Math.Vector.Vector3 +, module Spear.Math.Vector.Vector4 +, module Spear.Math.Vector.Class +) +where + +import Spear.Math.Vector.Vector2 +import Spear.Math.Vector.Vector3 +import Spear.Math.Vector.Vector4 +import Spear.Math.Vector.Class diff --git a/Spear/Math/Vector/Class.hs b/Spear/Math/Vector/Class.hs index 05a7206..19ddfac 100644 --- a/Spear/Math/Vector/Class.hs +++ b/Spear/Math/Vector/Class.hs @@ -1,43 +1,43 @@ -module Spear.Math.Vector.Class -where - -class (Fractional a, Ord a) => VectorClass a where - -- | Create a vector from the given list. - fromList :: [Float] -> a - - -- | Return the vector's x coordinate. - x :: a -> Float - x _ = 0 - - -- | Return the vector's y coordinate. - y :: a -> Float - y _ = 0 - - -- | Return the vector's z coordinate. - z :: a -> Float - z _ = 0 - - -- | Return the vector's w coordinate. - w :: a -> Float - w _ = 0 - - -- | Return the vector's ith coordinate. - (!) :: a -> Int -> Float - - -- | Compute the given vectors' dot product. - dot :: a -> a -> Float - - -- | Compute the given vector's squared norm. - normSq :: a -> Float - - -- | Compute the given vector's norm. - norm :: a -> Float - - -- | Multiply the given vector with the given scalar. - scale :: Float -> a -> a - - -- | Negate the given vector. - neg :: a -> a - - -- | Normalise the given vector. +module Spear.Math.Vector.Class +where + +class (Fractional a, Ord a) => VectorClass a where + -- | Create a vector from the given list. + fromList :: [Float] -> a + + -- | Return the vector's x coordinate. + x :: a -> Float + x _ = 0 + + -- | Return the vector's y coordinate. + y :: a -> Float + y _ = 0 + + -- | Return the vector's z coordinate. + z :: a -> Float + z _ = 0 + + -- | Return the vector's w coordinate. + w :: a -> Float + w _ = 0 + + -- | Return the vector's ith coordinate. + (!) :: a -> Int -> Float + + -- | Compute the given vectors' dot product. + dot :: a -> a -> Float + + -- | Compute the given vector's squared norm. + normSq :: a -> Float + + -- | Compute the given vector's norm. + norm :: a -> Float + + -- | Multiply the given vector with the given scalar. + scale :: Float -> a -> a + + -- | Negate the given vector. + neg :: a -> a + + -- | Normalise the given vector. 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 @@ -module Spear.Math.Vector.Vector2 -( - Vector2 - -- * Construction -, unitx2 -, unity2 -, zero2 -, vec2 - -- * Operations -, perp -) -where - - -import Spear.Math.Vector.Class - - -import Foreign.C.Types (CFloat) -import Foreign.Storable - - --- | Represents a vector in 2D. -data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) - - -instance Num Vector2 where - Vector2 ax ay + Vector2 bx by = Vector2 (ax + bx) (ay + by) - Vector2 ax ay - Vector2 bx by = Vector2 (ax - bx) (ay - by) - Vector2 ax ay * Vector2 bx by = Vector2 (ax * bx) (ay * by) - abs (Vector2 ax ay) = Vector2 (abs ax) (abs ay) - signum (Vector2 ax ay) = Vector2 (signum ax) (signum ay) - fromInteger i = Vector2 i' i' where i' = fromInteger i - - -instance Fractional Vector2 where - Vector2 ax ay / Vector2 bx by = Vector2 (ax / bx) (ay / by) - fromRational r = Vector2 r' r' where r' = fromRational r - - -instance Ord Vector2 where - Vector2 ax ay <= Vector2 bx by = (ax <= bx) || (ax == bx && ay <= by) - Vector2 ax ay >= Vector2 bx by = (ax >= bx) || (ax == bx && ay >= by) - Vector2 ax ay < Vector2 bx by = (ax < bx) || (ax == bx && ay < by) - Vector2 ax ay > Vector2 bx by = (ax > bx) || (ax == bx && ay > by) - max (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.max ax bx) (Prelude.max ay by) - min (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.min ax bx) (Prelude.min ay by) - - -instance VectorClass Vector2 where - {-# INLINABLE fromList #-} - fromList (ax:ay:_) = Vector2 ax ay - - {-# INLINABLE x #-} - x (Vector2 ax _) = ax - - {-# INLINABLE y #-} - y (Vector2 _ ay) = ay - - {-# INLINABLE (!) #-} - (Vector2 ax _) ! 0 = ax - (Vector2 _ ay) ! 1 = ay - _ ! _ = 0 - - {-# INLINABLE dot #-} - Vector2 ax ay `dot` Vector2 bx by = ax*bx + ay*by - - {-# INLINABLE normSq #-} - normSq (Vector2 ax ay) = ax*ax + ay*ay - - {-# INLINABLE norm #-} - norm = sqrt . normSq - - {-# INLINABLE scale #-} - scale s (Vector2 ax ay) = Vector2 (s*ax) (s*ay) - - {-# INLINABLE neg #-} - neg (Vector2 ax ay) = Vector2 (-ax) (-ay) - - {-# INLINABLE normalise #-} - normalise v = - let n' = norm v - n = if n' == 0 then 1 else n' - in scale (1.0 / n) v - - -sizeFloat = sizeOf (undefined :: CFloat) - - -instance Storable Vector2 where - sizeOf _ = 2*sizeFloat - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - ax <- peekByteOff ptr 0 - ay <- peekByteOff ptr $ sizeFloat - return (Vector2 ax ay) - - poke ptr (Vector2 ax ay) = do - pokeByteOff ptr 0 ax - pokeByteOff ptr sizeFloat ay - - --- | Get the vector's x coordinate. - - - --- | Unit vector along the X axis. -unitx2 = Vector2 1 0 - - --- | Unit vector along the Y axis. -unity2 = Vector2 0 1 - - --- | Zero vector. -zero2 = Vector2 0 0 - - --- | Create a vector from the given values. -vec2 :: Float -> Float -> Vector2 -vec2 ax ay = Vector2 ax ay - - --- | Compute a vector perpendicular to the given one, satisfying: --- --- perp (Vector2 0 1) = Vector2 1 0 --- --- perp (Vector2 1 0) = Vector2 0 (-1) -perp :: Vector2 -> Vector2 -perp (Vector2 x y) = Vector2 y (-x) +module Spear.Math.Vector.Vector2 +( + Vector2 + -- * Construction +, unitx2 +, unity2 +, zero2 +, vec2 + -- * Operations +, perp +) +where + + +import Spear.Math.Vector.Class + + +import Foreign.C.Types (CFloat) +import Foreign.Storable + + +-- | Represents a vector in 2D. +data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) + + +instance Num Vector2 where + Vector2 ax ay + Vector2 bx by = Vector2 (ax + bx) (ay + by) + Vector2 ax ay - Vector2 bx by = Vector2 (ax - bx) (ay - by) + Vector2 ax ay * Vector2 bx by = Vector2 (ax * bx) (ay * by) + abs (Vector2 ax ay) = Vector2 (abs ax) (abs ay) + signum (Vector2 ax ay) = Vector2 (signum ax) (signum ay) + fromInteger i = Vector2 i' i' where i' = fromInteger i + + +instance Fractional Vector2 where + Vector2 ax ay / Vector2 bx by = Vector2 (ax / bx) (ay / by) + fromRational r = Vector2 r' r' where r' = fromRational r + + +instance Ord Vector2 where + Vector2 ax ay <= Vector2 bx by = (ax <= bx) || (ax == bx && ay <= by) + Vector2 ax ay >= Vector2 bx by = (ax >= bx) || (ax == bx && ay >= by) + Vector2 ax ay < Vector2 bx by = (ax < bx) || (ax == bx && ay < by) + Vector2 ax ay > Vector2 bx by = (ax > bx) || (ax == bx && ay > by) + max (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.max ax bx) (Prelude.max ay by) + min (Vector2 ax ay) (Vector2 bx by) = Vector2 (Prelude.min ax bx) (Prelude.min ay by) + + +instance VectorClass Vector2 where + {-# INLINABLE fromList #-} + fromList (ax:ay:_) = Vector2 ax ay + + {-# INLINABLE x #-} + x (Vector2 ax _) = ax + + {-# INLINABLE y #-} + y (Vector2 _ ay) = ay + + {-# INLINABLE (!) #-} + (Vector2 ax _) ! 0 = ax + (Vector2 _ ay) ! 1 = ay + _ ! _ = 0 + + {-# INLINABLE dot #-} + Vector2 ax ay `dot` Vector2 bx by = ax*bx + ay*by + + {-# INLINABLE normSq #-} + normSq (Vector2 ax ay) = ax*ax + ay*ay + + {-# INLINABLE norm #-} + norm = sqrt . normSq + + {-# INLINABLE scale #-} + scale s (Vector2 ax ay) = Vector2 (s*ax) (s*ay) + + {-# INLINABLE neg #-} + neg (Vector2 ax ay) = Vector2 (-ax) (-ay) + + {-# INLINABLE normalise #-} + normalise v = + let n' = norm v + n = if n' == 0 then 1 else n' + in scale (1.0 / n) v + + +sizeFloat = sizeOf (undefined :: CFloat) + + +instance Storable Vector2 where + sizeOf _ = 2*sizeFloat + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + ax <- peekByteOff ptr 0 + ay <- peekByteOff ptr $ sizeFloat + return (Vector2 ax ay) + + poke ptr (Vector2 ax ay) = do + pokeByteOff ptr 0 ax + pokeByteOff ptr sizeFloat ay + + +-- | Get the vector's x coordinate. + + + +-- | Unit vector along the X axis. +unitx2 = Vector2 1 0 + + +-- | Unit vector along the Y axis. +unity2 = Vector2 0 1 + + +-- | Zero vector. +zero2 = Vector2 0 0 + + +-- | Create a vector from the given values. +vec2 :: Float -> Float -> Vector2 +vec2 ax ay = Vector2 ax ay + + +-- | Compute a vector perpendicular to the given one, satisfying: +-- +-- perp (Vector2 0 1) = Vector2 1 0 +-- +-- perp (Vector2 1 0) = Vector2 0 (-1) +perp :: Vector2 -> Vector2 +perp (Vector2 x y) = Vector2 y (-x) diff --git a/Spear/Math/Vector/Vector3.hs b/Spear/Math/Vector/Vector3.hs index 8a1cfa9..70bd299 100644 --- a/Spear/Math/Vector/Vector3.hs +++ b/Spear/Math/Vector/Vector3.hs @@ -1,184 +1,184 @@ -module Spear.Math.Vector.Vector3 -( - Vector3 -, Right3 -, Up3 -, Forward3 -, Position3 - -- * Construction -, unitx3 -, unity3 -, unitz3 -, zero3 -, vec3 -, orbit - -- * Operations -, cross -) -where - - -import Spear.Math.Vector.Class - -import Foreign.C.Types (CFloat) -import Foreign.Storable - -type Right3 = Vector3 -type Up3 = Vector3 -type Forward3 = Vector3 -type Position3 = Vector3 - - --- | Represents a vector in 3D. -data Vector3 = Vector3 - {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - deriving (Eq, Show) - -instance Num Vector3 where - Vector3 ax ay az + Vector3 bx by bz = Vector3 (ax + bx) (ay + by) (az + bz) - Vector3 ax ay az - Vector3 bx by bz = Vector3 (ax - bx) (ay - by) (az - bz) - Vector3 ax ay az * Vector3 bx by bz = Vector3 (ax * bx) (ay * by) (az * bz) - abs (Vector3 ax ay az) = Vector3 (abs ax) (abs ay) (abs az) - signum (Vector3 ax ay az) = Vector3 (signum ax) (signum ay) (signum az) - fromInteger i = Vector3 i' i' i' where i' = fromInteger i - - -instance Fractional Vector3 where - Vector3 ax ay az / Vector3 bx by bz = Vector3 (ax / bx) (ay / by) (az / bz) - fromRational r = Vector3 r' r' r' where r' = fromRational r - - -instance Ord Vector3 where - Vector3 ax ay az <= Vector3 bx by bz - = (ax <= bx) - || (az == bx && ay <= by) - || (ax == bx && ay == by && az <= bz) - - Vector3 ax ay az >= Vector3 bx by bz - = (ax >= bx) - || (ax == bx && ay >= by) - || (ax == bx && ay == by && az >= bz) - - Vector3 ax ay az < Vector3 bx by bz - = (ax < bx) - || (az == bx && ay < by) - || (ax == bx && ay == by && az < bz) - - Vector3 ax ay az > Vector3 bx by bz - = (ax > bx) - || (ax == bx && ay > by) - || (ax == bx && ay == by && az > bz) - - max (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) - - min (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) - - -instance VectorClass Vector3 where - {-# INLINABLE fromList #-} - fromList (ax:ay:az:_) = Vector3 ax ay az - - {-# INLINABLE x #-} - x (Vector3 ax _ _ ) = ax - - {-# INLINABLE y #-} - y (Vector3 _ ay _ ) = ay - - {-# INLINABLE z #-} - z (Vector3 _ _ az) = az - - {-# INLINABLE (!) #-} - (Vector3 ax _ _) ! 0 = ax - (Vector3 _ ay _) ! 1 = ay - (Vector3 _ _ az) ! 2 = az - _ ! _ = 0 - - {-# INLINABLE dot #-} - Vector3 ax ay az `dot` Vector3 bx by bz = ax*bx + ay*by + az*bz - - {-# INLINABLE normSq #-} - normSq (Vector3 ax ay az) = ax*ax + ay*ay + az*az - - {-# INLINABLE norm #-} - norm = sqrt . normSq - - {-# INLINABLE scale #-} - scale s (Vector3 ax ay az) = Vector3 (s*ax) (s*ay) (s*az) - - {-# INLINABLE neg #-} - neg (Vector3 ax ay az) = Vector3 (-ax) (-ay) (-az) - - {-# INLINABLE normalise #-} - normalise v = - let n' = norm v - n = if n' == 0 then 1 else n' - in scale (1.0 / n) v - - -sizeFloat = sizeOf (undefined :: CFloat) - - -instance Storable Vector3 where - sizeOf _ = 3*sizeFloat - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - ax <- peekByteOff ptr 0 - ay <- peekByteOff ptr $ 1*sizeFloat - az <- peekByteOff ptr $ 2*sizeFloat - return (Vector3 ax ay az) - - poke ptr (Vector3 ax ay az) = do - pokeByteOff ptr 0 ax - pokeByteOff ptr (1*sizeFloat) ay - pokeByteOff ptr (2*sizeFloat) az - - --- | Unit vector along the X axis. -unitx3 = Vector3 1 0 0 - - --- | Unit vector along the Y axis. -unity3 = Vector3 0 1 0 - - --- | Unit vector along the Z axis. -unitz3 = Vector3 0 0 1 - - --- | Zero vector. -zero3 = Vector3 0 0 0 - - --- | Create a 3D vector from the given values. -vec3 :: Float -> Float -> Float -> Vector3 -vec3 ax ay az = Vector3 ax ay az - - --- | Create a 3D vector as a point on a sphere. -orbit :: Vector3 -- ^ Sphere center. - -> Float -- ^ Sphere radius - -> Float -- ^ Azimuth angle. - -> Float -- ^ Zenith angle. - -> Vector3 - -orbit center radius anglex angley = - let ax = anglex * pi / 180 - ay = angley * pi / 180 - sx = sin ax - sy = sin ay - cx = cos ax - cy = cos ay - px = x center + radius*cy*sx - py = y center + radius*sy - pz = z center + radius*cx*cy - in - vec3 px py pz - - --- | Compute the given vectors' cross product. -cross :: Vector3 -> Vector3 -> Vector3 -(Vector3 ax ay az) `cross` (Vector3 bx by bz) = - Vector3 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx) +module Spear.Math.Vector.Vector3 +( + Vector3 +, Right3 +, Up3 +, Forward3 +, Position3 + -- * Construction +, unitx3 +, unity3 +, unitz3 +, zero3 +, vec3 +, orbit + -- * Operations +, cross +) +where + + +import Spear.Math.Vector.Class + +import Foreign.C.Types (CFloat) +import Foreign.Storable + +type Right3 = Vector3 +type Up3 = Vector3 +type Forward3 = Vector3 +type Position3 = Vector3 + + +-- | Represents a vector in 3D. +data Vector3 = Vector3 + {-# UNPACK #-} !Float + {-# UNPACK #-} !Float + {-# UNPACK #-} !Float + deriving (Eq, Show) + +instance Num Vector3 where + Vector3 ax ay az + Vector3 bx by bz = Vector3 (ax + bx) (ay + by) (az + bz) + Vector3 ax ay az - Vector3 bx by bz = Vector3 (ax - bx) (ay - by) (az - bz) + Vector3 ax ay az * Vector3 bx by bz = Vector3 (ax * bx) (ay * by) (az * bz) + abs (Vector3 ax ay az) = Vector3 (abs ax) (abs ay) (abs az) + signum (Vector3 ax ay az) = Vector3 (signum ax) (signum ay) (signum az) + fromInteger i = Vector3 i' i' i' where i' = fromInteger i + + +instance Fractional Vector3 where + Vector3 ax ay az / Vector3 bx by bz = Vector3 (ax / bx) (ay / by) (az / bz) + fromRational r = Vector3 r' r' r' where r' = fromRational r + + +instance Ord Vector3 where + Vector3 ax ay az <= Vector3 bx by bz + = (ax <= bx) + || (az == bx && ay <= by) + || (ax == bx && ay == by && az <= bz) + + Vector3 ax ay az >= Vector3 bx by bz + = (ax >= bx) + || (ax == bx && ay >= by) + || (ax == bx && ay == by && az >= bz) + + Vector3 ax ay az < Vector3 bx by bz + = (ax < bx) + || (az == bx && ay < by) + || (ax == bx && ay == by && az < bz) + + Vector3 ax ay az > Vector3 bx by bz + = (ax > bx) + || (ax == bx && ay > by) + || (ax == bx && ay == by && az > bz) + + max (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) + + min (Vector3 ax ay az) (Vector3 bx by bz) = Vector3 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) + + +instance VectorClass Vector3 where + {-# INLINABLE fromList #-} + fromList (ax:ay:az:_) = Vector3 ax ay az + + {-# INLINABLE x #-} + x (Vector3 ax _ _ ) = ax + + {-# INLINABLE y #-} + y (Vector3 _ ay _ ) = ay + + {-# INLINABLE z #-} + z (Vector3 _ _ az) = az + + {-# INLINABLE (!) #-} + (Vector3 ax _ _) ! 0 = ax + (Vector3 _ ay _) ! 1 = ay + (Vector3 _ _ az) ! 2 = az + _ ! _ = 0 + + {-# INLINABLE dot #-} + Vector3 ax ay az `dot` Vector3 bx by bz = ax*bx + ay*by + az*bz + + {-# INLINABLE normSq #-} + normSq (Vector3 ax ay az) = ax*ax + ay*ay + az*az + + {-# INLINABLE norm #-} + norm = sqrt . normSq + + {-# INLINABLE scale #-} + scale s (Vector3 ax ay az) = Vector3 (s*ax) (s*ay) (s*az) + + {-# INLINABLE neg #-} + neg (Vector3 ax ay az) = Vector3 (-ax) (-ay) (-az) + + {-# INLINABLE normalise #-} + normalise v = + let n' = norm v + n = if n' == 0 then 1 else n' + in scale (1.0 / n) v + + +sizeFloat = sizeOf (undefined :: CFloat) + + +instance Storable Vector3 where + sizeOf _ = 3*sizeFloat + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + ax <- peekByteOff ptr 0 + ay <- peekByteOff ptr $ 1*sizeFloat + az <- peekByteOff ptr $ 2*sizeFloat + return (Vector3 ax ay az) + + poke ptr (Vector3 ax ay az) = do + pokeByteOff ptr 0 ax + pokeByteOff ptr (1*sizeFloat) ay + pokeByteOff ptr (2*sizeFloat) az + + +-- | Unit vector along the X axis. +unitx3 = Vector3 1 0 0 + + +-- | Unit vector along the Y axis. +unity3 = Vector3 0 1 0 + + +-- | Unit vector along the Z axis. +unitz3 = Vector3 0 0 1 + + +-- | Zero vector. +zero3 = Vector3 0 0 0 + + +-- | Create a 3D vector from the given values. +vec3 :: Float -> Float -> Float -> Vector3 +vec3 ax ay az = Vector3 ax ay az + + +-- | Create a 3D vector as a point on a sphere. +orbit :: Vector3 -- ^ Sphere center. + -> Float -- ^ Sphere radius + -> Float -- ^ Azimuth angle. + -> Float -- ^ Zenith angle. + -> Vector3 + +orbit center radius anglex angley = + let ax = anglex * pi / 180 + ay = angley * pi / 180 + sx = sin ax + sy = sin ay + cx = cos ax + cy = cos ay + px = x center + radius*cy*sx + py = y center + radius*sy + pz = z center + radius*cx*cy + in + vec3 px py pz + + +-- | Compute the given vectors' cross product. +cross :: Vector3 -> Vector3 -> Vector3 +(Vector3 ax ay az) `cross` (Vector3 bx by bz) = + 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 @@ -module Spear.Math.Vector.Vector4 -( - Vector4 - -- * Construction -, unitx4 -, unity4 -, unitz4 -, vec4 - -- * Operations -, cross' -) -where - - -import Spear.Math.Vector.Class - -import Foreign.C.Types (CFloat) -import Foreign.Storable - - --- | Represents a vector in 3D. -data Vector4 = Vector4 - {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - deriving (Eq, Show) - - -instance Num Vector4 where - Vector4 ax ay az aw + Vector4 bx by bz bw = Vector4 (ax + bx) (ay + by) (az + bz) (aw + bw) - Vector4 ax ay az aw - Vector4 bx by bz bw = Vector4 (ax - bx) (ay - by) (az - bz) (aw - bw) - Vector4 ax ay az aw * Vector4 bx by bz bw = Vector4 (ax * bx) (ay * by) (az * bz) (aw * bw) - abs (Vector4 ax ay az aw) = Vector4 (abs ax) (abs ay) (abs az) (abs aw) - signum (Vector4 ax ay az aw) = Vector4 (signum ax) (signum ay) (signum az) (signum aw) - fromInteger i = Vector4 i' i' i' i' where i' = fromInteger i - - -instance Fractional Vector4 where - Vector4 ax ay az aw / Vector4 bx by bz bw = Vector4 (ax / bx) (ay / by) (az / bz) (aw / bw) - fromRational r = Vector4 r' r' r' r' where r' = fromRational r - - -instance Ord Vector4 where - Vector4 ax ay az aw <= Vector4 bx by bz bw - = (ax <= bx) - || (az == bx && ay <= by) - || (ax == bx && ay == by && az <= bz) - || (ax == bx && ay == by && az == bz && aw <= bw) - - Vector4 ax ay az aw >= Vector4 bx by bz bw - = (ax >= bx) - || (ax == bx && ay >= by) - || (ax == bx && ay == by && az >= bz) - || (ax == bx && ay == by && az == bz && aw >= bw) - - Vector4 ax ay az aw < Vector4 bx by bz bw - = (ax < bx) - || (az == bx && ay < by) - || (ax == bx && ay == by && az < bz) - || (ax == bx && ay == by && az == bz && aw < bw) - - Vector4 ax ay az aw > Vector4 bx by bz bw - = (ax > bx) - || (ax == bx && ay > by) - || (ax == bx && ay == by && az > bz) - || (ax == bx && ay == by && az == bz && aw > bw) - - min (Vector4 ax ay az aw) (Vector4 bx by bz bw) = - Vector4 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) (Prelude.min aw bw) - - max (Vector4 ax ay az aw) (Vector4 bx by bz bw) = - Vector4 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) (Prelude.min aw bw) - - -instance VectorClass Vector4 where - {-# INLINABLE fromList #-} - fromList (ax:ay:az:aw:_) = Vector4 ax ay az aw - - {-# INLINABLE x #-} - x (Vector4 ax _ _ _ ) = ax - - {-# INLINABLE y #-} - y (Vector4 _ ay _ _ ) = ay - - {-# INLINABLE z #-} - z (Vector4 _ _ az _ ) = az - - {-# INLINABLE w #-} - w (Vector4 _ _ _ aw) = aw - - {-# INLINABLE (!) #-} - (Vector4 ax _ _ _) ! 0 = ax - (Vector4 _ ay _ _) ! 1 = ay - (Vector4 _ _ az _) ! 2 = az - (Vector4 _ _ _ aw) ! 3 = aw - _ ! _ = 0 - - {-# INLINABLE dot #-} - Vector4 ax ay az aw `dot` Vector4 bx by bz bw = ax*bx + ay*by + az*bz + aw*bw - - {-# INLINABLE normSq #-} - normSq (Vector4 ax ay az aw) = ax*ax + ay*ay + az*az + aw*aw - - {-# INLINABLE norm #-} - norm = sqrt . normSq - - {-# INLINABLE scale #-} - scale s (Vector4 ax ay az aw) = Vector4 (s*ax) (s*ay) (s*az) (s*aw) - - {-# INLINABLE neg #-} - neg (Vector4 ax ay az aw) = Vector4 (-ax) (-ay) (-az) (-aw) - - {-# INLINABLE normalise #-} - normalise v = - let n' = norm v - n = if n' == 0 then 1 else n' - in scale (1.0 / n) v - - -sizeFloat = sizeOf (undefined :: CFloat) - - -instance Storable Vector4 where - sizeOf _ = 4*sizeFloat - alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - ax <- peekByteOff ptr 0 - ay <- peekByteOff ptr $ 1 * sizeFloat - az <- peekByteOff ptr $ 2 * sizeFloat - aw <- peekByteOff ptr $ 3 * sizeFloat - return (Vector4 ax ay az aw) - - poke ptr (Vector4 ax ay az aw) = do - pokeByteOff ptr 0 ax - pokeByteOff ptr (1 * sizeFloat) ay - pokeByteOff ptr (2 * sizeFloat) az - pokeByteOff ptr (3 * sizeFloat) aw - - --- | Unit vector along the X axis. -unitx4 = Vector4 1 0 0 0 - - --- | Unit vector along the Y axis. -unity4 = Vector4 0 1 0 0 - - --- | Unit vector along the Z axis. -unitz4 = Vector4 0 0 1 0 - --- | Unit vector along the W axis. -unitw4 = Vector4 0 0 0 1 - - --- | Create a 4D vector from the given values. -vec4 :: Float -> Float -> Float -> Float -> Vector4 -vec4 ax ay az aw = Vector4 ax ay az aw - - --- | Compute the given vectors' cross product. --- The vectors are projected to 3D space. The resulting vector is the cross product of the vectors' projections with w=0. -cross' :: Vector4 -> Vector4 -> Vector4 -(Vector4 ax ay az _) `cross'` (Vector4 bx by bz _) = - Vector4 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx) 0 +module Spear.Math.Vector.Vector4 +( + Vector4 + -- * Construction +, unitx4 +, unity4 +, unitz4 +, vec4 + -- * Operations +, cross' +) +where + + +import Spear.Math.Vector.Class + +import Foreign.C.Types (CFloat) +import Foreign.Storable + + +-- | Represents a vector in 3D. +data Vector4 = Vector4 + {-# UNPACK #-} !Float + {-# UNPACK #-} !Float + {-# UNPACK #-} !Float + {-# UNPACK #-} !Float + deriving (Eq, Show) + + +instance Num Vector4 where + Vector4 ax ay az aw + Vector4 bx by bz bw = Vector4 (ax + bx) (ay + by) (az + bz) (aw + bw) + Vector4 ax ay az aw - Vector4 bx by bz bw = Vector4 (ax - bx) (ay - by) (az - bz) (aw - bw) + Vector4 ax ay az aw * Vector4 bx by bz bw = Vector4 (ax * bx) (ay * by) (az * bz) (aw * bw) + abs (Vector4 ax ay az aw) = Vector4 (abs ax) (abs ay) (abs az) (abs aw) + signum (Vector4 ax ay az aw) = Vector4 (signum ax) (signum ay) (signum az) (signum aw) + fromInteger i = Vector4 i' i' i' i' where i' = fromInteger i + + +instance Fractional Vector4 where + Vector4 ax ay az aw / Vector4 bx by bz bw = Vector4 (ax / bx) (ay / by) (az / bz) (aw / bw) + fromRational r = Vector4 r' r' r' r' where r' = fromRational r + + +instance Ord Vector4 where + Vector4 ax ay az aw <= Vector4 bx by bz bw + = (ax <= bx) + || (az == bx && ay <= by) + || (ax == bx && ay == by && az <= bz) + || (ax == bx && ay == by && az == bz && aw <= bw) + + Vector4 ax ay az aw >= Vector4 bx by bz bw + = (ax >= bx) + || (ax == bx && ay >= by) + || (ax == bx && ay == by && az >= bz) + || (ax == bx && ay == by && az == bz && aw >= bw) + + Vector4 ax ay az aw < Vector4 bx by bz bw + = (ax < bx) + || (az == bx && ay < by) + || (ax == bx && ay == by && az < bz) + || (ax == bx && ay == by && az == bz && aw < bw) + + Vector4 ax ay az aw > Vector4 bx by bz bw + = (ax > bx) + || (ax == bx && ay > by) + || (ax == bx && ay == by && az > bz) + || (ax == bx && ay == by && az == bz && aw > bw) + + min (Vector4 ax ay az aw) (Vector4 bx by bz bw) = + Vector4 (Prelude.min ax bx) (Prelude.min ay by) (Prelude.min az bz) (Prelude.min aw bw) + + max (Vector4 ax ay az aw) (Vector4 bx by bz bw) = + Vector4 (Prelude.max ax bx) (Prelude.max ay by) (Prelude.max az bz) (Prelude.min aw bw) + + +instance VectorClass Vector4 where + {-# INLINABLE fromList #-} + fromList (ax:ay:az:aw:_) = Vector4 ax ay az aw + + {-# INLINABLE x #-} + x (Vector4 ax _ _ _ ) = ax + + {-# INLINABLE y #-} + y (Vector4 _ ay _ _ ) = ay + + {-# INLINABLE z #-} + z (Vector4 _ _ az _ ) = az + + {-# INLINABLE w #-} + w (Vector4 _ _ _ aw) = aw + + {-# INLINABLE (!) #-} + (Vector4 ax _ _ _) ! 0 = ax + (Vector4 _ ay _ _) ! 1 = ay + (Vector4 _ _ az _) ! 2 = az + (Vector4 _ _ _ aw) ! 3 = aw + _ ! _ = 0 + + {-# INLINABLE dot #-} + Vector4 ax ay az aw `dot` Vector4 bx by bz bw = ax*bx + ay*by + az*bz + aw*bw + + {-# INLINABLE normSq #-} + normSq (Vector4 ax ay az aw) = ax*ax + ay*ay + az*az + aw*aw + + {-# INLINABLE norm #-} + norm = sqrt . normSq + + {-# INLINABLE scale #-} + scale s (Vector4 ax ay az aw) = Vector4 (s*ax) (s*ay) (s*az) (s*aw) + + {-# INLINABLE neg #-} + neg (Vector4 ax ay az aw) = Vector4 (-ax) (-ay) (-az) (-aw) + + {-# INLINABLE normalise #-} + normalise v = + let n' = norm v + n = if n' == 0 then 1 else n' + in scale (1.0 / n) v + + +sizeFloat = sizeOf (undefined :: CFloat) + + +instance Storable Vector4 where + sizeOf _ = 4*sizeFloat + alignment _ = alignment (undefined :: CFloat) + + peek ptr = do + ax <- peekByteOff ptr 0 + ay <- peekByteOff ptr $ 1 * sizeFloat + az <- peekByteOff ptr $ 2 * sizeFloat + aw <- peekByteOff ptr $ 3 * sizeFloat + return (Vector4 ax ay az aw) + + poke ptr (Vector4 ax ay az aw) = do + pokeByteOff ptr 0 ax + pokeByteOff ptr (1 * sizeFloat) ay + pokeByteOff ptr (2 * sizeFloat) az + pokeByteOff ptr (3 * sizeFloat) aw + + +-- | Unit vector along the X axis. +unitx4 = Vector4 1 0 0 0 + + +-- | Unit vector along the Y axis. +unity4 = Vector4 0 1 0 0 + + +-- | Unit vector along the Z axis. +unitz4 = Vector4 0 0 1 0 + +-- | Unit vector along the W axis. +unitw4 = Vector4 0 0 0 1 + + +-- | Create a 4D vector from the given values. +vec4 :: Float -> Float -> Float -> Float -> Vector4 +vec4 ax ay az aw = Vector4 ax ay az aw + + +-- | Compute the given vectors' cross product. +-- The vectors are projected to 3D space. The resulting vector is the cross product of the vectors' projections with w=0. +cross' :: Vector4 -> Vector4 -> Vector4 +(Vector4 ax ay az _) `cross'` (Vector4 bx by bz _) = + 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 @@ -module Spear.Render.AnimatedModel -( - -- * Data types - AnimatedModelResource -, AnimatedModelRenderer -, AnimationSpeed - -- * Construction and destruction -, animatedModelResource -, animatedModelRenderer - -- * Accessors -, animationSpeed -, box -, currentAnimation -, currentFrame -, frameProgress -, modelRes -, nextFrame - -- * Manipulation -, update -, setAnimation -, setAnimationSpeed - -- * Rendering -, bind -, render - -- * Collision -, mkColsFromAnimated -) -where - -import Spear.Assets.Model -import Spear.Game -import Spear.GL -import Spear.Math.AABB -import Spear.Math.Collision -import Spear.Math.Matrix4 (Matrix4) -import Spear.Math.Vector -import Spear.Render.Material -import Spear.Render.Model -import Spear.Render.Program - -import Control.Applicative ((<$>), (<*>)) -import qualified Data.Vector as V -import Unsafe.Coerce (unsafeCoerce) - -type AnimationSpeed = Float - --- | An animated model resource. --- --- Contains model data necessary to render an animated model. -data AnimatedModelResource = AnimatedModelResource - { model :: Model - , vao :: VAO - , nFrames :: Int - , nVertices :: Int - , material :: Material - , texture :: Texture - , boxes :: V.Vector Box - , rkey :: Resource - } - -instance Eq AnimatedModelResource where - m1 == m2 = vao m1 == vao m2 - -instance Ord AnimatedModelResource where - m1 < m2 = vao m1 < vao m2 - -instance ResourceClass AnimatedModelResource where - getResource = rkey - --- | An animated model renderer. --- --- Holds animation data necessary to render an animated model and a reference --- to an 'AnimatedModelResource'. --- --- Model data is kept separate from animation data. This allows instances --- of 'AnimatedModelRenderer' to share the underlying 'AnimatedModelResource', --- minimising the amount of data in memory and allowing one to minimise OpenGL --- state changes by sorting 'AnimatedModelRenderer's by their underlying --- 'AnimatedModelResource' when rendering the scene. -data AnimatedModelRenderer = AnimatedModelRenderer - { modelResource :: AnimatedModelResource - , currentAnim :: Int - , frameStart :: Int - , frameEnd :: Int - , currentFrame :: Int -- ^ Get the renderer's current frame. - , frameProgress :: Float -- ^ Get the renderer's frame progress. - , animationSpeed :: Float -- ^ Get the renderer's animation speed. - } - -instance Eq AnimatedModelRenderer where - m1 == m2 = modelResource m1 == modelResource m2 - -instance Ord AnimatedModelRenderer where - m1 < m2 = modelResource m1 < modelResource m2 - --- | Create an model resource from the given model. -animatedModelResource :: AnimatedProgramChannels - -> Material - -> Texture - -> Model - -> Game s AnimatedModelResource - -animatedModelResource - (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan) - material texture model = do - RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model - elementBuf <- newBuffer - vao <- newVAO - boxes <- gameIO $ modelBoxes model - - gameIO $ do - - let elemSize = 56 - elemSize' = fromIntegral elemSize - n = numVertices * numFrames - - bindVAO vao - - bindBuffer elementBuf ArrayBuffer - bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw - - attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0 - attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12 - attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24 - attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36 - attribVAOPointer texChan 2 gl_FLOAT False elemSize' 48 - - enableVAOAttrib vertChan1 - enableVAOAttrib vertChan2 - enableVAOAttrib normChan1 - enableVAOAttrib normChan2 - enableVAOAttrib texChan - - rkey <- register $ do - putStrLn "Releasing animated model resource" - clean vao - clean elementBuf - - return $ AnimatedModelResource - model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices) - material texture boxes rkey - --- | Create a renderer from the given model resource. -animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer -animatedModelRenderer animSpeed modelResource = - AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed - --- | Update the renderer. -update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = - AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s - where f = fp + dt * s - nextFrame = f >= 1.0 - fp' = if nextFrame then f - 1.0 else f - curFrame' = if nextFrame - then let x = curFrame + 1 - in if x > endFrame then startFrame else x - else curFrame - --- | Get the model's ith bounding box. -box :: Int -> AnimatedModelResource -> Box -box i model = boxes model V.! i - --- | Get the renderer's current animation. -currentAnimation :: Enum a => AnimatedModelRenderer -> a -currentAnimation = toEnum . currentAnim - --- | Get the renderer's model resource. -modelRes :: AnimatedModelRenderer -> AnimatedModelResource -modelRes = modelResource - --- | Get the renderer's next frame. -nextFrame :: AnimatedModelRenderer -> Int -nextFrame rend = - let curFrame = currentFrame rend - in - if curFrame == frameEnd rend - then frameStart rend - else curFrame + 1 - --- | Set the active animation to the given one. -setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer -setAnimation anim modelRend = - let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim' - anim' = fromEnum anim - in - modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 } - --- | Set the renderer's animation speed. -setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer -setAnimationSpeed s r = r { animationSpeed = s } - --- | Bind the given renderer to prepare it for rendering. -bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () -bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = - let model' = modelResource modelRend - in do - bindVAO . vao $ model' - bindTexture $ texture model' - activeTexture $= gl_TEXTURE0 - glUniform1i texLoc 0 - --- | Render the model described by the given renderer. -render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () -render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = - let n = nVertices model - (Material _ ka kd ks shi) = material model - in do - uniform (kaLoc uniforms) ka - uniform (kdLoc uniforms) kd - uniform (ksLoc uniforms) ks - glUniform1f (shiLoc uniforms) $ unsafeCoerce shi - glUniform1f (fpLoc uniforms) (unsafeCoerce fp) - drawArrays gl_TRIANGLES (n*curFrame) n - --- | Compute AABB collisioners in view space from the given model. -mkColsFromAnimated - :: Int -- ^ Source frame - -> Int -- ^ Dest frame - -> Float -- ^ Frame progress - -> Matrix4 -- ^ Modelview matrix - -> AnimatedModelResource - -> [Collisioner2] -mkColsFromAnimated f1 f2 fp modelview modelRes = - let - (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes - (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes - min1 = vec3 xmin1 ymin1 zmin1 - max1 = vec3 xmax1 ymax1 zmax1 - min2 = vec3 xmin2 ymin2 zmin2 - max2 = vec3 xmax2 ymax2 zmax2 - min = min1 + scale fp (min2 - min1) - max = max1 + scale fp (max2 - max1) - in - mkCols modelview - $ Box (Vec3 (x min) (y min) (z min)) (Vec3 (x max) (y max) (z max)) +module Spear.Render.AnimatedModel +( + -- * Data types + AnimatedModelResource +, AnimatedModelRenderer +, AnimationSpeed + -- * Construction and destruction +, animatedModelResource +, animatedModelRenderer + -- * Accessors +, animationSpeed +, box +, currentAnimation +, currentFrame +, frameProgress +, modelRes +, nextFrame + -- * Manipulation +, update +, setAnimation +, setAnimationSpeed + -- * Rendering +, bind +, render + -- * Collision +, mkColsFromAnimated +) +where + +import Spear.Assets.Model +import Spear.Game +import Spear.GL +import Spear.Math.AABB +import Spear.Math.Collision +import Spear.Math.Matrix4 (Matrix4) +import Spear.Math.Vector +import Spear.Render.Material +import Spear.Render.Model +import Spear.Render.Program + +import Control.Applicative ((<$>), (<*>)) +import qualified Data.Vector as V +import Unsafe.Coerce (unsafeCoerce) + +type AnimationSpeed = Float + +-- | An animated model resource. +-- +-- Contains model data necessary to render an animated model. +data AnimatedModelResource = AnimatedModelResource + { model :: Model + , vao :: VAO + , nFrames :: Int + , nVertices :: Int + , material :: Material + , texture :: Texture + , boxes :: V.Vector Box + , rkey :: Resource + } + +instance Eq AnimatedModelResource where + m1 == m2 = vao m1 == vao m2 + +instance Ord AnimatedModelResource where + m1 < m2 = vao m1 < vao m2 + +instance ResourceClass AnimatedModelResource where + getResource = rkey + +-- | An animated model renderer. +-- +-- Holds animation data necessary to render an animated model and a reference +-- to an 'AnimatedModelResource'. +-- +-- Model data is kept separate from animation data. This allows instances +-- of 'AnimatedModelRenderer' to share the underlying 'AnimatedModelResource', +-- minimising the amount of data in memory and allowing one to minimise OpenGL +-- state changes by sorting 'AnimatedModelRenderer's by their underlying +-- 'AnimatedModelResource' when rendering the scene. +data AnimatedModelRenderer = AnimatedModelRenderer + { modelResource :: AnimatedModelResource + , currentAnim :: Int + , frameStart :: Int + , frameEnd :: Int + , currentFrame :: Int -- ^ Get the renderer's current frame. + , frameProgress :: Float -- ^ Get the renderer's frame progress. + , animationSpeed :: Float -- ^ Get the renderer's animation speed. + } + +instance Eq AnimatedModelRenderer where + m1 == m2 = modelResource m1 == modelResource m2 + +instance Ord AnimatedModelRenderer where + m1 < m2 = modelResource m1 < modelResource m2 + +-- | Create an model resource from the given model. +animatedModelResource :: AnimatedProgramChannels + -> Material + -> Texture + -> Model + -> Game s AnimatedModelResource + +animatedModelResource + (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan) + material texture model = do + RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model + elementBuf <- newBuffer + vao <- newVAO + boxes <- gameIO $ modelBoxes model + + gameIO $ do + + let elemSize = 56 + elemSize' = fromIntegral elemSize + n = numVertices * numFrames + + bindVAO vao + + bindBuffer ArrayBuffer elementBuf + bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw + + attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0 + attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12 + attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24 + attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36 + attribVAOPointer texChan 2 gl_FLOAT False elemSize' 48 + + enableVAOAttrib vertChan1 + enableVAOAttrib vertChan2 + enableVAOAttrib normChan1 + enableVAOAttrib normChan2 + enableVAOAttrib texChan + + rkey <- register $ do + putStrLn "Releasing animated model resource" + clean vao + clean elementBuf + + return $ AnimatedModelResource + model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices) + material texture boxes rkey + +-- | Create a renderer from the given model resource. +animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer +animatedModelRenderer animSpeed modelResource = + AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed + +-- | Update the renderer. +update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = + AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s + where f = fp + dt * s + nextFrame = f >= 1.0 + fp' = if nextFrame then f - 1.0 else f + curFrame' = if nextFrame + then let x = curFrame + 1 + in if x > endFrame then startFrame else x + else curFrame + +-- | Get the model's ith bounding box. +box :: Int -> AnimatedModelResource -> Box +box i model = boxes model V.! i + +-- | Get the renderer's current animation. +currentAnimation :: Enum a => AnimatedModelRenderer -> a +currentAnimation = toEnum . currentAnim + +-- | Get the renderer's model resource. +modelRes :: AnimatedModelRenderer -> AnimatedModelResource +modelRes = modelResource + +-- | Get the renderer's next frame. +nextFrame :: AnimatedModelRenderer -> Int +nextFrame rend = + let curFrame = currentFrame rend + in + if curFrame == frameEnd rend + then frameStart rend + else curFrame + 1 + +-- | Set the active animation to the given one. +setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer +setAnimation anim modelRend = + let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim' + anim' = fromEnum anim + in + modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 } + +-- | Set the renderer's animation speed. +setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer +setAnimationSpeed s r = r { animationSpeed = s } + +-- | Bind the given renderer to prepare it for rendering. +bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () +bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = + let model' = modelResource modelRend + in do + bindVAO . vao $ model' + bindTexture $ texture model' + activeTexture $= gl_TEXTURE0 + glUniform1i texLoc 0 + +-- | Render the model described by the given renderer. +render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () +render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = + let n = nVertices model + (Material _ ka kd ks shi) = material model + in do + uniform (kaLoc uniforms) ka + uniform (kdLoc uniforms) kd + uniform (ksLoc uniforms) ks + glUniform1f (shiLoc uniforms) $ unsafeCoerce shi + glUniform1f (fpLoc uniforms) (unsafeCoerce fp) + drawArrays gl_TRIANGLES (n*curFrame) n + +-- | Compute AABB collisioners in view space from the given model. +mkColsFromAnimated + :: Int -- ^ Source frame + -> Int -- ^ Dest frame + -> Float -- ^ Frame progress + -> Matrix4 -- ^ Modelview matrix + -> AnimatedModelResource + -> [Collisioner2] +mkColsFromAnimated f1 f2 fp modelview modelRes = + let + (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes + (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes + min1 = vec3 xmin1 ymin1 zmin1 + max1 = vec3 xmax1 ymax1 zmax1 + min2 = vec3 xmin2 ymin2 zmin2 + max2 = vec3 xmax2 ymax2 zmax2 + min = min1 + scale fp (min2 - min1) + max = max1 + scale fp (max2 - max1) + in + mkCols modelview + $ 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 @@ -module Spear.Render.Box -( - render -, renderOutwards -, renderInwards -, renderEdges -) -where - - -import Spear.Math.Vector3 -import Spear.Math.Matrix -import Graphics.Rendering.OpenGL.Raw -import Unsafe.Coerce -import Control.Monad.Instances - -type Center = Vector3 -type Colour = Vector4 -type Length = Float -type Normals = [Vector3] -type GenerateTexCoords = Bool - - -applyColour :: Colour -> IO () ---applyColour col = glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) (unsafeCoerce $ w col) -applyColour = do - ax <- unsafeCoerce . x - ay <- unsafeCoerce . y - az <- unsafeCoerce . z - aw <- unsafeCoerce . w - glColor4f ax ay az aw - - -applyNormal :: Vector3 -> IO () ---applyNormal v = glNormal3f (unsafeCoerce $ x v) (unsafeCoerce $ y v) (unsafeCoerce $ z v) -applyNormal = do - nx <- unsafeCoerce . x - ny <- unsafeCoerce . y - nz <- unsafeCoerce . z - glNormal3f nx ny nz - - --- | Renders a box. -render :: Center -- ^ The box's center. - -> Length -- ^ The perpendicular distance from the box's center to any of its sides. - -> Colour -- ^ The box's colour. - -> Normals -- ^ The box's normals, of the form [front, back, right, left, top, bottom]. - -> IO () -render c l col normals = do - glPushMatrix - glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) - applyColour col - - let d = unsafeCoerce l - glBegin gl_QUADS - - --Front - --glNormal3f 0 0 (-1) - applyNormal $ normals !! 0 - glVertex3f d (-d) (-d) - glVertex3f d d (-d) - glVertex3f (-d) d (-d) - glVertex3f (-d) (-d) (-d) - - --Back - --glNormal3f 0 0 1 - applyNormal $ normals !! 1 - glVertex3f (-d) (-d) d - glVertex3f (-d) d d - glVertex3f d d d - glVertex3f d (-d) d - - --Right - --glNormal3f 1 0 0 - applyNormal $ normals !! 2 - glVertex3f d (-d) (-d) - glVertex3f d (-d) d - glVertex3f d d d - glVertex3f d d (-d) - - --Left - --glNormal3f (-1) 0 0 - applyNormal $ normals !! 3 - glVertex3f (-d) (-d) (-d) - glVertex3f (-d) d (-d) - glVertex3f (-d) d d - glVertex3f (-d) (-d) d - - --Top - --glNormal3f 0 1 0 - applyNormal $ normals !! 4 - glVertex3f (-d) d (-d) - glVertex3f d d (-d) - glVertex3f d d d - glVertex3f (-d) d d - - --Bottom - --glNormal3f 0 (-1) 0 - applyNormal $ normals !! 5 - glVertex3f d (-d) d - glVertex3f d (-d) (-d) - glVertex3f (-d) (-d) (-d) - glVertex3f (-d) (-d) d - - glEnd - - glPopMatrix - - -normals = [vec3 0 0 (-1), vec3 0 0 1, vec3 1 0 0, vec3 (-1) 0 0, vec3 0 1 0, vec3 0 (-1) 0] - - --- | Renders a box with normals facing outwards. -renderOutwards :: Center -- ^ The box's center. - -> Length -- ^ The perpendicular distance from the box's center to any of its sides. - -> Colour -- ^ The box's colour. - -> IO () -renderOutwards c l col = render c l col normals - - --- | Renders a box with normals facing inwards. -renderInwards :: Center -- ^ The box's center. - -> Length -- ^ The perpendicular distance from the box's center to any of its sides. - -> Colour -- ^ The box's colour. - -> IO () -renderInwards c l col = do - glFrontFace gl_CW - render c l col $ Prelude.map neg normals - glFrontFace gl_CCW - - -renderEdges :: Center -- ^ The box's center. - -> Length -- ^ The perpendicular distance from the box's center to any of its sides. - -> Colour -- ^ The box's colour. - -> IO () -renderEdges c l col = do - glPushMatrix - glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) - applyColour col - - let d = unsafeCoerce l - - --Front - glBegin gl_LINE_STRIP - glVertex3f d (-d) (-d) - glVertex3f d d (-d) - glVertex3f (-d) d (-d) - glVertex3f (-d) (-d) (-d) - glEnd - - --Back - glBegin gl_LINE_STRIP - glVertex3f (-d) (-d) d - glVertex3f (-d) d d - glVertex3f d d d - glVertex3f d (-d) d - glVertex3f (-d) (-d) d - glEnd - - --Right - glBegin gl_LINE_STRIP - glVertex3f d (-d) (-d) - glVertex3f d (-d) d - glVertex3f d d d - glVertex3f d d (-d) - glEnd - - --Left - glBegin gl_LINE_STRIP - glVertex3f (-d) (-d) (-d) - glVertex3f (-d) d (-d) - glVertex3f (-d) d d - glVertex3f (-d) (-d) d - glEnd - - --Top - glBegin gl_LINE_STRIP - glVertex3f (-d) d (-d) - glVertex3f d d (-d) - glVertex3f d d d - glVertex3f (-d) d d - glEnd - - --Bottom - glBegin gl_LINE_STRIP - glVertex3f d (-d) d - glVertex3f d (-d) (-d) - glVertex3f (-d) (-d) (-d) - glVertex3f (-d) (-d) d - glEnd - - glPopMatrix +module Spear.Render.Box +( + render +, renderOutwards +, renderInwards +, renderEdges +) +where + + +import Spear.Math.Vector3 +import Spear.Math.Matrix +import Graphics.Rendering.OpenGL.Raw +import Unsafe.Coerce +import Control.Monad.Instances + +type Center = Vector3 +type Colour = Vector4 +type Length = Float +type Normals = [Vector3] +type GenerateTexCoords = Bool + + +applyColour :: Colour -> IO () +--applyColour col = glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) (unsafeCoerce $ w col) +applyColour = do + ax <- unsafeCoerce . x + ay <- unsafeCoerce . y + az <- unsafeCoerce . z + aw <- unsafeCoerce . w + glColor4f ax ay az aw + + +applyNormal :: Vector3 -> IO () +--applyNormal v = glNormal3f (unsafeCoerce $ x v) (unsafeCoerce $ y v) (unsafeCoerce $ z v) +applyNormal = do + nx <- unsafeCoerce . x + ny <- unsafeCoerce . y + nz <- unsafeCoerce . z + glNormal3f nx ny nz + + +-- | Renders a box. +render :: Center -- ^ The box's center. + -> Length -- ^ The perpendicular distance from the box's center to any of its sides. + -> Colour -- ^ The box's colour. + -> Normals -- ^ The box's normals, of the form [front, back, right, left, top, bottom]. + -> IO () +render c l col normals = do + glPushMatrix + glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) + applyColour col + + let d = unsafeCoerce l + glBegin gl_QUADS + + --Front + --glNormal3f 0 0 (-1) + applyNormal $ normals !! 0 + glVertex3f d (-d) (-d) + glVertex3f d d (-d) + glVertex3f (-d) d (-d) + glVertex3f (-d) (-d) (-d) + + --Back + --glNormal3f 0 0 1 + applyNormal $ normals !! 1 + glVertex3f (-d) (-d) d + glVertex3f (-d) d d + glVertex3f d d d + glVertex3f d (-d) d + + --Right + --glNormal3f 1 0 0 + applyNormal $ normals !! 2 + glVertex3f d (-d) (-d) + glVertex3f d (-d) d + glVertex3f d d d + glVertex3f d d (-d) + + --Left + --glNormal3f (-1) 0 0 + applyNormal $ normals !! 3 + glVertex3f (-d) (-d) (-d) + glVertex3f (-d) d (-d) + glVertex3f (-d) d d + glVertex3f (-d) (-d) d + + --Top + --glNormal3f 0 1 0 + applyNormal $ normals !! 4 + glVertex3f (-d) d (-d) + glVertex3f d d (-d) + glVertex3f d d d + glVertex3f (-d) d d + + --Bottom + --glNormal3f 0 (-1) 0 + applyNormal $ normals !! 5 + glVertex3f d (-d) d + glVertex3f d (-d) (-d) + glVertex3f (-d) (-d) (-d) + glVertex3f (-d) (-d) d + + glEnd + + glPopMatrix + + +normals = [vec3 0 0 (-1), vec3 0 0 1, vec3 1 0 0, vec3 (-1) 0 0, vec3 0 1 0, vec3 0 (-1) 0] + + +-- | Renders a box with normals facing outwards. +renderOutwards :: Center -- ^ The box's center. + -> Length -- ^ The perpendicular distance from the box's center to any of its sides. + -> Colour -- ^ The box's colour. + -> IO () +renderOutwards c l col = render c l col normals + + +-- | Renders a box with normals facing inwards. +renderInwards :: Center -- ^ The box's center. + -> Length -- ^ The perpendicular distance from the box's center to any of its sides. + -> Colour -- ^ The box's colour. + -> IO () +renderInwards c l col = do + glFrontFace gl_CW + render c l col $ Prelude.map neg normals + glFrontFace gl_CCW + + +renderEdges :: Center -- ^ The box's center. + -> Length -- ^ The perpendicular distance from the box's center to any of its sides. + -> Colour -- ^ The box's colour. + -> IO () +renderEdges c l col = do + glPushMatrix + glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) + applyColour col + + let d = unsafeCoerce l + + --Front + glBegin gl_LINE_STRIP + glVertex3f d (-d) (-d) + glVertex3f d d (-d) + glVertex3f (-d) d (-d) + glVertex3f (-d) (-d) (-d) + glEnd + + --Back + glBegin gl_LINE_STRIP + glVertex3f (-d) (-d) d + glVertex3f (-d) d d + glVertex3f d d d + glVertex3f d (-d) d + glVertex3f (-d) (-d) d + glEnd + + --Right + glBegin gl_LINE_STRIP + glVertex3f d (-d) (-d) + glVertex3f d (-d) d + glVertex3f d d d + glVertex3f d d (-d) + glEnd + + --Left + glBegin gl_LINE_STRIP + glVertex3f (-d) (-d) (-d) + glVertex3f (-d) d (-d) + glVertex3f (-d) d d + glVertex3f (-d) (-d) d + glEnd + + --Top + glBegin gl_LINE_STRIP + glVertex3f (-d) d (-d) + glVertex3f d d (-d) + glVertex3f d d d + glVertex3f (-d) d d + glEnd + + --Bottom + glBegin gl_LINE_STRIP + glVertex3f d (-d) d + glVertex3f d (-d) (-d) + glVertex3f (-d) (-d) (-d) + glVertex3f (-d) (-d) d + glEnd + + glPopMatrix \ 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 @@ -module Spear.Render.Material -( Material(..) -) -where - - -import Spear.Math.Vector - - -data Material = Material - { ke :: Vector4 - , ka :: Vector4 - , kd :: Vector4 - , ks :: Vector4 - , shininess :: Float - } +module Spear.Render.Material +( Material(..) +) +where + + +import Spear.Math.Vector + + +data Material = Material + { ke :: Vector4 + , ka :: Vector4 + , kd :: Vector4 + , ks :: Vector4 + , shininess :: Float + } 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 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - -module Spear.Render.Model -( - RenderModel(..) -, renderModelFromModel -) -where - -import qualified Spear.Assets.Model as Assets -import Spear.Game - -import Foreign.Ptr -import Foreign.C.Types -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import Foreign.Marshal.Utils (with) -import Foreign.Storable - -#include "RenderModel.h" - -data Vec3 = Vec3 !CFloat !CFloat !CFloat - -data TexCoord = TexCoord !CFloat !CFloat - -data RenderModel = RenderModel - { elements :: Ptr CChar - , numFrames :: CUInt - , numVertices :: CUInt -- ^ Number of vertices per frame. - } - -instance Storable RenderModel where - sizeOf _ = #{size RenderModel} - alignment _ = alignment (undefined :: CUInt) - - peek ptr = do - elements <- #{peek RenderModel, elements} ptr - numFrames <- #{peek RenderModel, numFrames} ptr - numVertices <- #{peek RenderModel, numVertices} ptr - return $ RenderModel elements numFrames numVertices - - poke ptr (RenderModel elements numFrames numVertices) = do - #{poke RenderModel, elements} ptr elements - #{poke RenderModel, numFrames} ptr numFrames - #{poke RenderModel, numVertices} ptr numVertices - -foreign import ccall "RenderModel.h render_model_from_model_asset" - render_model_from_model_asset :: Ptr Assets.Model -> Ptr RenderModel -> IO Int - --- | Convert the given 'Model' to a 'ModelData' instance. -renderModelFromModel :: Assets.Model -> IO RenderModel -renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do - render_model_from_model_asset mPtr mdPtr - peek mdPtr +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Spear.Render.Model +( + RenderModel(..) +, renderModelFromModel +) +where + +import qualified Spear.Assets.Model as Assets +import Spear.Game + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Marshal.Utils (with) +import Foreign.Storable + +#include "RenderModel.h" + +data Vec3 = Vec3 !CFloat !CFloat !CFloat + +data TexCoord = TexCoord !CFloat !CFloat + +data RenderModel = RenderModel + { elements :: Ptr CChar + , numFrames :: CUInt + , numVertices :: CUInt -- ^ Number of vertices per frame. + } + +instance Storable RenderModel where + sizeOf _ = #{size RenderModel} + alignment _ = alignment (undefined :: CUInt) + + peek ptr = do + elements <- #{peek RenderModel, elements} ptr + numFrames <- #{peek RenderModel, numFrames} ptr + numVertices <- #{peek RenderModel, numVertices} ptr + return $ RenderModel elements numFrames numVertices + + poke ptr (RenderModel elements numFrames numVertices) = do + #{poke RenderModel, elements} ptr elements + #{poke RenderModel, numFrames} ptr numFrames + #{poke RenderModel, numVertices} ptr numVertices + +foreign import ccall "RenderModel.h render_model_from_model_asset" + render_model_from_model_asset :: Ptr Assets.Model -> Ptr RenderModel -> IO Int + +-- | Convert the given 'Model' to a 'ModelData' instance. +renderModelFromModel :: Assets.Model -> IO RenderModel +renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do + render_model_from_model_asset mPtr mdPtr + 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 @@ -module Spear.Render.Program -( - StaticProgram(..) -, AnimatedProgram(..) -, Program(..) -, ProgramUniforms(..) -, StaticProgramChannels(..) -, StaticProgramUniforms(..) -, AnimatedProgramChannels(..) -, AnimatedProgramUniforms(..) -) -where - -import Spear.GL - -data StaticProgram = StaticProgram - { staticProgram :: GLSLProgram - , staticProgramChannels :: StaticProgramChannels - , staticProgramUniforms :: StaticProgramUniforms - } - -data AnimatedProgram = AnimatedProgram - { animatedProgram :: GLSLProgram - , animatedProgramChannels :: AnimatedProgramChannels - , animatedProgramUniforms :: AnimatedProgramUniforms - } - -data StaticProgramChannels = StaticProgramChannels - { vertexChannel :: GLuint -- ^ Vertex channel. - , normalChannel :: GLuint -- ^ Normal channel. - , stexChannel :: GLuint -- ^ Texture channel. - } - -data AnimatedProgramChannels = AnimatedProgramChannels - { vertexChannel1 :: GLuint -- ^ Vertex channel 1. - , vertexChannel2 :: GLuint -- ^ Vertex channel 2. - , normalChannel1 :: GLuint -- ^ Normal channel 1. - , normalChannel2 :: GLuint -- ^ Normal channel 2. - , atexChannel :: GLuint -- ^ Texture channel. - } - -data StaticProgramUniforms = StaticProgramUniforms - { skaLoc :: GLint -- ^ Material ambient uniform location. - , skdLoc :: GLint -- ^ Material diffuse uniform location. - , sksLoc :: GLint -- ^ Material specular uniform location. - , sshiLoc :: GLint -- ^ Material shininess uniform location. - , stexLoc :: GLint -- ^ Texture sampler location. - , smodelviewLoc :: GLint -- ^ Modelview matrix location. - , snormalmatLoc :: GLint -- ^ Normal matrix location. - , sprojLoc :: GLint -- ^ Projection matrix location. - } - -data AnimatedProgramUniforms = AnimatedProgramUniforms - { akaLoc :: GLint -- ^ Material ambient uniform location. - , akdLoc :: GLint -- ^ Material diffuse uniform location. - , aksLoc :: GLint -- ^ Material specular uniform location. - , ashiLoc :: GLint -- ^ Material shininess uniform location. - , atexLoc :: GLint -- ^ Texture sampler location. - , fpLoc :: GLint -- ^ Frame progress uniform location. - , amodelviewLoc :: GLint -- ^ Modelview matrix location. - , anormalmatLoc :: GLint -- ^ Normal matrix location. - , aprojLoc :: GLint -- ^ Projection matrix location. - } - -class Program a where - program :: a -> GLSLProgram - -instance Program StaticProgram where - program = staticProgram - -instance Program AnimatedProgram where - program = animatedProgram - -class ProgramUniforms a where - kaLoc :: a -> GLint - kdLoc :: a -> GLint - ksLoc :: a -> GLint - shiLoc :: a -> GLint - texLoc :: a -> GLint - modelviewLoc :: a -> GLint - normalmatLoc :: a -> GLint - projLoc :: a -> GLint - -instance ProgramUniforms StaticProgramUniforms where - kaLoc = skaLoc - kdLoc = skdLoc - ksLoc = sksLoc - shiLoc = sshiLoc - texLoc = stexLoc - modelviewLoc = smodelviewLoc - normalmatLoc = snormalmatLoc - projLoc = sprojLoc - -instance ProgramUniforms AnimatedProgramUniforms where - kaLoc = akaLoc - kdLoc = akdLoc - ksLoc = aksLoc - shiLoc = ashiLoc - texLoc = atexLoc - modelviewLoc = amodelviewLoc - normalmatLoc = anormalmatLoc - projLoc = aprojLoc +module Spear.Render.Program +( + StaticProgram(..) +, AnimatedProgram(..) +, Program(..) +, ProgramUniforms(..) +, StaticProgramChannels(..) +, StaticProgramUniforms(..) +, AnimatedProgramChannels(..) +, AnimatedProgramUniforms(..) +) +where + +import Spear.GL + +data StaticProgram = StaticProgram + { staticProgram :: GLSLProgram + , staticProgramChannels :: StaticProgramChannels + , staticProgramUniforms :: StaticProgramUniforms + } + +data AnimatedProgram = AnimatedProgram + { animatedProgram :: GLSLProgram + , animatedProgramChannels :: AnimatedProgramChannels + , animatedProgramUniforms :: AnimatedProgramUniforms + } + +data StaticProgramChannels = StaticProgramChannels + { vertexChannel :: GLuint -- ^ Vertex channel. + , normalChannel :: GLuint -- ^ Normal channel. + , stexChannel :: GLuint -- ^ Texture channel. + } + +data AnimatedProgramChannels = AnimatedProgramChannels + { vertexChannel1 :: GLuint -- ^ Vertex channel 1. + , vertexChannel2 :: GLuint -- ^ Vertex channel 2. + , normalChannel1 :: GLuint -- ^ Normal channel 1. + , normalChannel2 :: GLuint -- ^ Normal channel 2. + , atexChannel :: GLuint -- ^ Texture channel. + } + +data StaticProgramUniforms = StaticProgramUniforms + { skaLoc :: GLint -- ^ Material ambient uniform location. + , skdLoc :: GLint -- ^ Material diffuse uniform location. + , sksLoc :: GLint -- ^ Material specular uniform location. + , sshiLoc :: GLint -- ^ Material shininess uniform location. + , stexLoc :: GLint -- ^ Texture sampler location. + , smodelviewLoc :: GLint -- ^ Modelview matrix location. + , snormalmatLoc :: GLint -- ^ Normal matrix location. + , sprojLoc :: GLint -- ^ Projection matrix location. + } + +data AnimatedProgramUniforms = AnimatedProgramUniforms + { akaLoc :: GLint -- ^ Material ambient uniform location. + , akdLoc :: GLint -- ^ Material diffuse uniform location. + , aksLoc :: GLint -- ^ Material specular uniform location. + , ashiLoc :: GLint -- ^ Material shininess uniform location. + , atexLoc :: GLint -- ^ Texture sampler location. + , fpLoc :: GLint -- ^ Frame progress uniform location. + , amodelviewLoc :: GLint -- ^ Modelview matrix location. + , anormalmatLoc :: GLint -- ^ Normal matrix location. + , aprojLoc :: GLint -- ^ Projection matrix location. + } + +class Program a where + program :: a -> GLSLProgram + +instance Program StaticProgram where + program = staticProgram + +instance Program AnimatedProgram where + program = animatedProgram + +class ProgramUniforms a where + kaLoc :: a -> GLint + kdLoc :: a -> GLint + ksLoc :: a -> GLint + shiLoc :: a -> GLint + texLoc :: a -> GLint + modelviewLoc :: a -> GLint + normalmatLoc :: a -> GLint + projLoc :: a -> GLint + +instance ProgramUniforms StaticProgramUniforms where + kaLoc = skaLoc + kdLoc = skdLoc + ksLoc = sksLoc + shiLoc = sshiLoc + texLoc = stexLoc + modelviewLoc = smodelviewLoc + normalmatLoc = snormalmatLoc + projLoc = sprojLoc + +instance ProgramUniforms AnimatedProgramUniforms where + kaLoc = akaLoc + kdLoc = akdLoc + ksLoc = aksLoc + shiLoc = ashiLoc + texLoc = atexLoc + modelviewLoc = amodelviewLoc + normalmatLoc = anormalmatLoc + 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 @@ -#include "RenderModel.h" -#include // free -#include // memcpy -#include - - -static void safe_free (void* ptr) -{ - if (ptr) - { - free (ptr); - ptr = 0; - } -} - - -/// Populate elements of an animated model to be rendered from -/// start to end in a loop. -/*int populate_elements_animated (Model* model_asset, RenderModel* model) -{ - size_t nverts = model_asset->numVertices; - size_t ntriangles = model_asset->numTriangles; - size_t nframes = model_asset->numFrames; - size_t n = nframes * ntriangles * 3; - - model->elements = malloc (56 * n); - if (!model->elements) return -1; - - // Populate elements. - - size_t f, i; - - char* elem = (char*) model->elements; - vec3* v1 = model_asset->vertices; - vec3* v2 = v1 + nverts; - vec3* n1 = model_asset->normals; - vec3* n2 = n1 + nverts; - texCoord* tex = model_asset->texCoords; - - for (f = 0; f < nframes; ++f) - { - triangle* t = model_asset->triangles; - - for (i = 0; i < ntriangles; ++i) - { - *((vec3*) elem) = v1[t->vertexIndices[0]]; - *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; - *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; - *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; - *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; - elem += 56; - - *((vec3*) elem) = v1[t->vertexIndices[1]]; - *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; - *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; - *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; - *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; - elem += 56; - - *((vec3*) elem) = v1[t->vertexIndices[2]]; - *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; - *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; - *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; - *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; - elem += 56; - - t++; - } - - v1 += nverts; - v2 += nverts; - n1 += nverts; - n2 += nverts; - - if (f == nframes-2) - { - v2 = model_asset->vertices; - n2 = model_asset->normals; - } - } - - return 0; -}*/ - - -/// Populate elements of an animated model according to its frames -/// of animation. -int populate_elements_animated (Model* model_asset, RenderModel* model) -{ - size_t nverts = model_asset->numVertices; - size_t ntriangles = model_asset->numTriangles; - size_t nframes = model_asset->numFrames; - size_t n = nframes * ntriangles * 3; - - model->elements = malloc (56 * n); - if (!model->elements) return -1; - - // Populate elements. - - unsigned f, i, j, u; - - char* elem = (char*) model->elements; - animation* anim = model_asset->animations; - - for (i = 0; i < model_asset->numAnimations; ++i, anim++) - { - unsigned start = anim->start; - unsigned end = anim->end; - - char singleFrameAnim = start == end; - - vec3* v1 = model_asset->vertices + start*nverts; - vec3* v2 = singleFrameAnim ? v1 : v1 + nverts; - vec3* n1 = model_asset->normals + start*nverts; - vec3* n2 = singleFrameAnim ? n1 : n1 + nverts; - texCoord* tex = model_asset->texCoords; - - for (u = start; u <= end; ++u) - { - triangle* t = model_asset->triangles; - - for (j = 0; j < ntriangles; ++j, t++) - { - *((vec3*) elem) = v1[t->vertexIndices[0]]; - *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; - *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; - *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; - *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; - elem += 56; - - *((vec3*) elem) = v1[t->vertexIndices[1]]; - *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; - *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; - *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; - *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; - elem += 56; - - *((vec3*) elem) = v1[t->vertexIndices[2]]; - *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; - *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; - *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; - *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; - elem += 56; - } - - // Advance to the next frame of animation of the current - // animation. - v1 += nverts; - v2 += nverts; - n1 += nverts; - n2 += nverts; - - // Reset the secondary pointers to the beginning of the - // animation when we are about to reach the last frame. - if (u == end-1) - { - v2 = model_asset->vertices + start*nverts; - n2 = model_asset->normals + start*nverts; - } - } - } - - return 0; -} - - -int populate_elements_static (Model* model_asset, RenderModel* model) -{ - size_t nverts = model_asset->numVertices; - size_t ntriangles = model_asset->numTriangles; - size_t n = ntriangles * 3; - - model->elements = malloc (32 * n); - if (!model->elements) return -1; - - // Populate elements. - - size_t f, i; - - char* elem = (char*) model->elements; - vec3* vert = model_asset->vertices; - vec3* norm = model_asset->normals; - texCoord* tex = model_asset->texCoords; - - triangle* t = model_asset->triangles; - - for (i = 0; i < ntriangles; ++i) - { - *((vec3*) elem) = vert[t->vertexIndices[0]]; - *((vec3*) (elem + 12)) = norm[t->vertexIndices[0]]; - *((texCoord*) (elem + 24)) = tex[t->textureIndices[0]]; - elem += 32; - - *((vec3*) elem) = vert[t->vertexIndices[1]]; - *((vec3*) (elem + 12)) = norm[t->vertexIndices[1]]; - *((texCoord*) (elem + 24)) = tex[t->textureIndices[1]]; - elem += 32; - - *((vec3*) elem) = vert[t->vertexIndices[2]]; - *((vec3*) (elem + 12)) = norm[t->vertexIndices[2]]; - *((texCoord*) (elem + 24)) = tex[t->textureIndices[2]]; - elem += 32; - - t++; - } - - return 0; -} - - -int render_model_from_model_asset (Model* model_asset, RenderModel* model) -{ - U32 ntriangles = model_asset->numTriangles; - U32 nframes = model_asset->numFrames; - - int result; - if (nframes > 1) result = populate_elements_animated (model_asset, model); - else result = populate_elements_static (model_asset, model); - - if (result != 0) return result; - - model->numFrames = nframes; - model->numVertices = ntriangles * 3; // Number of vertices per frame. - - return 0; -} - - -void render_model_free (RenderModel* model) -{ - safe_free (model->elements); -} +#include "RenderModel.h" +#include // free +#include // memcpy +#include + + +static void safe_free (void* ptr) +{ + if (ptr) + { + free (ptr); + ptr = 0; + } +} + + +/// Populate elements of an animated model to be rendered from +/// start to end in a loop. +/*int populate_elements_animated (Model* model_asset, RenderModel* model) +{ + size_t nverts = model_asset->numVertices; + size_t ntriangles = model_asset->numTriangles; + size_t nframes = model_asset->numFrames; + size_t n = nframes * ntriangles * 3; + + model->elements = malloc (56 * n); + if (!model->elements) return -1; + + // Populate elements. + + size_t f, i; + + char* elem = (char*) model->elements; + vec3* v1 = model_asset->vertices; + vec3* v2 = v1 + nverts; + vec3* n1 = model_asset->normals; + vec3* n2 = n1 + nverts; + texCoord* tex = model_asset->texCoords; + + for (f = 0; f < nframes; ++f) + { + triangle* t = model_asset->triangles; + + for (i = 0; i < ntriangles; ++i) + { + *((vec3*) elem) = v1[t->vertexIndices[0]]; + *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; + *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; + *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; + *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; + elem += 56; + + *((vec3*) elem) = v1[t->vertexIndices[1]]; + *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; + *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; + *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; + *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; + elem += 56; + + *((vec3*) elem) = v1[t->vertexIndices[2]]; + *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; + *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; + *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; + *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; + elem += 56; + + t++; + } + + v1 += nverts; + v2 += nverts; + n1 += nverts; + n2 += nverts; + + if (f == nframes-2) + { + v2 = model_asset->vertices; + n2 = model_asset->normals; + } + } + + return 0; +}*/ + + +/// Populate elements of an animated model according to its frames +/// of animation. +int populate_elements_animated (Model* model_asset, RenderModel* model) +{ + size_t nverts = model_asset->numVertices; + size_t ntriangles = model_asset->numTriangles; + size_t nframes = model_asset->numFrames; + size_t n = nframes * ntriangles * 3; + + model->elements = malloc (56 * n); + if (!model->elements) return -1; + + // Populate elements. + + unsigned f, i, j, u; + + char* elem = (char*) model->elements; + animation* anim = model_asset->animations; + + for (i = 0; i < model_asset->numAnimations; ++i, anim++) + { + unsigned start = anim->start; + unsigned end = anim->end; + + char singleFrameAnim = start == end; + + vec3* v1 = model_asset->vertices + start*nverts; + vec3* v2 = singleFrameAnim ? v1 : v1 + nverts; + vec3* n1 = model_asset->normals + start*nverts; + vec3* n2 = singleFrameAnim ? n1 : n1 + nverts; + texCoord* tex = model_asset->texCoords; + + for (u = start; u <= end; ++u) + { + triangle* t = model_asset->triangles; + + for (j = 0; j < ntriangles; ++j, t++) + { + *((vec3*) elem) = v1[t->vertexIndices[0]]; + *((vec3*) (elem + 12)) = v2[t->vertexIndices[0]]; + *((vec3*) (elem + 24)) = n1[t->vertexIndices[0]]; + *((vec3*) (elem + 36)) = n2[t->vertexIndices[0]]; + *((texCoord*) (elem + 48)) = tex[t->textureIndices[0]]; + elem += 56; + + *((vec3*) elem) = v1[t->vertexIndices[1]]; + *((vec3*) (elem + 12)) = v2[t->vertexIndices[1]]; + *((vec3*) (elem + 24)) = n1[t->vertexIndices[1]]; + *((vec3*) (elem + 36)) = n2[t->vertexIndices[1]]; + *((texCoord*) (elem + 48)) = tex[t->textureIndices[1]]; + elem += 56; + + *((vec3*) elem) = v1[t->vertexIndices[2]]; + *((vec3*) (elem + 12)) = v2[t->vertexIndices[2]]; + *((vec3*) (elem + 24)) = n1[t->vertexIndices[2]]; + *((vec3*) (elem + 36)) = n2[t->vertexIndices[2]]; + *((texCoord*) (elem + 48)) = tex[t->textureIndices[2]]; + elem += 56; + } + + // Advance to the next frame of animation of the current + // animation. + v1 += nverts; + v2 += nverts; + n1 += nverts; + n2 += nverts; + + // Reset the secondary pointers to the beginning of the + // animation when we are about to reach the last frame. + if (u == end-1) + { + v2 = model_asset->vertices + start*nverts; + n2 = model_asset->normals + start*nverts; + } + } + } + + return 0; +} + + +int populate_elements_static (Model* model_asset, RenderModel* model) +{ + size_t nverts = model_asset->numVertices; + size_t ntriangles = model_asset->numTriangles; + size_t n = ntriangles * 3; + + model->elements = malloc (32 * n); + if (!model->elements) return -1; + + // Populate elements. + + size_t f, i; + + char* elem = (char*) model->elements; + vec3* vert = model_asset->vertices; + vec3* norm = model_asset->normals; + texCoord* tex = model_asset->texCoords; + + triangle* t = model_asset->triangles; + + for (i = 0; i < ntriangles; ++i) + { + *((vec3*) elem) = vert[t->vertexIndices[0]]; + *((vec3*) (elem + 12)) = norm[t->vertexIndices[0]]; + *((texCoord*) (elem + 24)) = tex[t->textureIndices[0]]; + elem += 32; + + *((vec3*) elem) = vert[t->vertexIndices[1]]; + *((vec3*) (elem + 12)) = norm[t->vertexIndices[1]]; + *((texCoord*) (elem + 24)) = tex[t->textureIndices[1]]; + elem += 32; + + *((vec3*) elem) = vert[t->vertexIndices[2]]; + *((vec3*) (elem + 12)) = norm[t->vertexIndices[2]]; + *((texCoord*) (elem + 24)) = tex[t->textureIndices[2]]; + elem += 32; + + t++; + } + + return 0; +} + + +int render_model_from_model_asset (Model* model_asset, RenderModel* model) +{ + U32 ntriangles = model_asset->numTriangles; + U32 nframes = model_asset->numFrames; + + int result; + if (nframes > 1) result = populate_elements_animated (model_asset, model); + else result = populate_elements_static (model_asset, model); + + if (result != 0) return result; + + model->numFrames = nframes; + model->numVertices = ntriangles * 3; // Number of vertices per frame. + + return 0; +} + + +void render_model_free (RenderModel* model) +{ + safe_free (model->elements); +} 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 @@ -#ifndef _SPEAR_RENDER_MODEL_H -#define _SPEAR_RENDER_MODEL_H - -#include "Model.h" - - -/// Represents a renderable model. -/** - * If the model is animated: - * - * Buffer layout: - * vert1 vert2 norm1 norm2 texc - * - * element size = (3 + 3 + 3 + 3 + 2)*4 = 56 B - * buffer size = element size * num vertices = 56n - * - * If the model is static: - * - * Buffer layout: - * vert norm texc - * - * element size = (3 + 3 + 2)*4 = 32 B - * buffer size = element size * num vertices = 32n - * - **/ -typedef struct -{ - void* elements; - U32 numFrames; - U32 numVertices; // Number of vertices per frame. -} -RenderModel; - - -#ifdef __cplusplus -extern "C" { -#endif - -int render_model_from_model_asset (Model* model_asset, RenderModel* render_model); - -void render_model_free (RenderModel* model); - -#ifdef __cplusplus -} -#endif - - -#endif // _SPEAR_RENDER_MODEL_H - +#ifndef _SPEAR_RENDER_MODEL_H +#define _SPEAR_RENDER_MODEL_H + +#include "Model.h" + + +/// Represents a renderable model. +/** + * If the model is animated: + * + * Buffer layout: + * vert1 vert2 norm1 norm2 texc + * + * element size = (3 + 3 + 3 + 3 + 2)*4 = 56 B + * buffer size = element size * num vertices = 56n + * + * If the model is static: + * + * Buffer layout: + * vert norm texc + * + * element size = (3 + 3 + 2)*4 = 32 B + * buffer size = element size * num vertices = 32n + * + **/ +typedef struct +{ + void* elements; + U32 numFrames; + U32 numVertices; // Number of vertices per frame. +} +RenderModel; + + +#ifdef __cplusplus +extern "C" { +#endif + +int render_model_from_model_asset (Model* model_asset, RenderModel* render_model); + +void render_model_free (RenderModel* model); + +#ifdef __cplusplus +} +#endif + + +#endif // _SPEAR_RENDER_MODEL_H + 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 @@ -module Spear.Render.Sphere -( - render -) -where - - -import Spear.Math.Vector as Vector -import Spear.Math.Matrix -import Graphics.Rendering.OpenGL.Raw -import Graphics.Rendering.OpenGL.GL.Colors -import qualified Graphics.Rendering.OpenGL.GLU as GLU -import Unsafe.Coerce - - -type Center = Vector R -type Radius = R -type Colour = Vector R - - -applyColour :: Colour -> IO () -applyColour col = - if Vector.length col == 4 then - glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) - (unsafeCoerce $ w col) - else - glColor3f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) - - --- | Renders a sphere. --- Center is the sphere's center. --- Radius is the sphere's radius. --- Colour is a Vector representing the sphere's colour. Colour may hold an alpha channel. -render :: Center -> Radius -> Colour -> IO () -render c radius col = do - glPushMatrix - glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) - applyColour col - - let r = unsafeCoerce $ (realToFrac radius :: Double) - let style = GLU.QuadricStyle (Just Smooth) GLU.NoTextureCoordinates GLU.Outside GLU.FillStyle - GLU.renderQuadric style $ GLU.Sphere r 16 16 - - glPopMatrix +module Spear.Render.Sphere +( + render +) +where + + +import Spear.Math.Vector as Vector +import Spear.Math.Matrix +import Graphics.Rendering.OpenGL.Raw +import Graphics.Rendering.OpenGL.GL.Colors +import qualified Graphics.Rendering.OpenGL.GLU as GLU +import Unsafe.Coerce + + +type Center = Vector R +type Radius = R +type Colour = Vector R + + +applyColour :: Colour -> IO () +applyColour col = + if Vector.length col == 4 then + glColor4f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) + (unsafeCoerce $ w col) + else + glColor3f (unsafeCoerce $ x col) (unsafeCoerce $ y col) (unsafeCoerce $ z col) + + +-- | Renders a sphere. +-- Center is the sphere's center. +-- Radius is the sphere's radius. +-- Colour is a Vector representing the sphere's colour. Colour may hold an alpha channel. +render :: Center -> Radius -> Colour -> IO () +render c radius col = do + glPushMatrix + glTranslatef (unsafeCoerce $ x c) (unsafeCoerce $ y c) (unsafeCoerce $ z c) + applyColour col + + let r = unsafeCoerce $ (realToFrac radius :: Double) + let style = GLU.QuadricStyle (Just Smooth) GLU.NoTextureCoordinates GLU.Outside GLU.FillStyle + GLU.renderQuadric style $ GLU.Sphere r 16 16 + + glPopMatrix \ 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 @@ -module Spear.Render.StaticModel -( - -- * Data types - StaticModelResource -, StaticModelRenderer - -- * Construction and destruction -, staticModelResource -, staticModelRenderer - -- * Manipulation -, box -, modelRes - -- * Rendering -, bind -, render - -- * Collision -, mkColsFromStatic -) -where - -import Spear.Assets.Model -import Spear.Game -import Spear.GL -import Spear.Math.AABB -import Spear.Math.Collision -import Spear.Math.Matrix4 (Matrix4) -import Spear.Math.Vector -import Spear.Render.Material -import Spear.Render.Model -import Spear.Render.Program - -import qualified Data.Vector as V -import Unsafe.Coerce (unsafeCoerce) - -data StaticModelResource = StaticModelResource - { vao :: VAO - , nVertices :: Int - , material :: Material - , texture :: Texture - , boxes :: V.Vector Box - , rkey :: Resource - } - -instance Eq StaticModelResource where - m1 == m2 = vao m1 == vao m2 - -instance Ord StaticModelResource where - m1 < m2 = vao m1 < vao m2 - -instance ResourceClass StaticModelResource where - getResource = rkey - -data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } - -instance Eq StaticModelRenderer where - m1 == m2 = model m1 == model m2 - -instance Ord StaticModelRenderer where - m1 < m2 = model m1 < model m2 - --- | Create a model resource from the given model. -staticModelResource :: StaticProgramChannels - -> Material - -> Texture - -> Model - -> Game s StaticModelResource - -staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do - RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model - elementBuf <- newBuffer - vao <- newVAO - boxes <- gameIO $ modelBoxes model - - gameIO $ do - - let elemSize = 32 - elemSize' = fromIntegral elemSize - n = numVertices - - bindVAO vao - - bindBuffer elementBuf ArrayBuffer - bufferData' ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw - - attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0 - attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12 - attribVAOPointer texChan 2 gl_FLOAT False elemSize' 24 - - enableVAOAttrib vertChan - enableVAOAttrib normChan - enableVAOAttrib texChan - - rkey <- register $ do - putStrLn "Releasing static model resource" - clean vao - clean elementBuf - - return $ StaticModelResource - vao (unsafeCoerce numVertices) material texture boxes rkey - --- | Create a renderer from the given model resource. -staticModelRenderer :: StaticModelResource -> StaticModelRenderer -staticModelRenderer = StaticModelRenderer - --- | Get the model's ith bounding box. -box :: Int -> StaticModelResource -> Box -box i model = boxes model V.! i - --- | Get the renderer's model resource. -modelRes :: StaticModelRenderer -> StaticModelResource -modelRes = model - --- | Bind the given renderer to prepare it for rendering. -bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () -bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = - let (Material _ ka kd ks shi) = material model - in do - bindVAO . vao $ model - bindTexture $ texture model - activeTexture $= gl_TEXTURE0 - glUniform1i texLoc 0 - --- | Render the given renderer. -render :: StaticProgramUniforms -> StaticModelRenderer -> IO () -render uniforms (StaticModelRenderer model) = - let (Material _ ka kd ks shi) = material model - in do - uniform (kaLoc uniforms) ka - uniform (kdLoc uniforms) kd - uniform (ksLoc uniforms) ks - glUniform1f (shiLoc uniforms) $ unsafeCoerce shi - drawArrays gl_TRIANGLES 0 $ nVertices model - --- | Compute AABB collisioners in view space from the given model. -mkColsFromStatic - :: Matrix4 -- ^ Modelview matrix - -> StaticModelResource - -> [Collisioner2] -mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) +module Spear.Render.StaticModel +( + -- * Data types + StaticModelResource +, StaticModelRenderer + -- * Construction and destruction +, staticModelResource +, staticModelRenderer + -- * Manipulation +, box +, modelRes + -- * Rendering +, bind +, render + -- * Collision +, mkColsFromStatic +) +where + +import Spear.Assets.Model +import Spear.Game +import Spear.GL +import Spear.Math.AABB +import Spear.Math.Collision +import Spear.Math.Matrix4 (Matrix4) +import Spear.Math.Vector +import Spear.Render.Material +import Spear.Render.Model +import Spear.Render.Program + +import qualified Data.Vector as V +import Unsafe.Coerce (unsafeCoerce) + +data StaticModelResource = StaticModelResource + { vao :: VAO + , nVertices :: Int + , material :: Material + , texture :: Texture + , boxes :: V.Vector Box + , rkey :: Resource + } + +instance Eq StaticModelResource where + m1 == m2 = vao m1 == vao m2 + +instance Ord StaticModelResource where + m1 < m2 = vao m1 < vao m2 + +instance ResourceClass StaticModelResource where + getResource = rkey + +data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } + +instance Eq StaticModelRenderer where + m1 == m2 = model m1 == model m2 + +instance Ord StaticModelRenderer where + m1 < m2 = model m1 < model m2 + +-- | Create a model resource from the given model. +staticModelResource :: StaticProgramChannels + -> Material + -> Texture + -> Model + -> Game s StaticModelResource + +staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do + RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model + elementBuf <- newBuffer + vao <- newVAO + boxes <- gameIO $ modelBoxes model + + gameIO $ do + + let elemSize = 32 + elemSize' = fromIntegral elemSize + n = numVertices + + bindVAO vao + + bindBuffer ArrayBuffer elementBuf + bufferData' ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw + + attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0 + attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12 + attribVAOPointer texChan 2 gl_FLOAT False elemSize' 24 + + enableVAOAttrib vertChan + enableVAOAttrib normChan + enableVAOAttrib texChan + + rkey <- register $ do + putStrLn "Releasing static model resource" + clean vao + clean elementBuf + + return $ StaticModelResource + vao (unsafeCoerce numVertices) material texture boxes rkey + +-- | Create a renderer from the given model resource. +staticModelRenderer :: StaticModelResource -> StaticModelRenderer +staticModelRenderer = StaticModelRenderer + +-- | Get the model's ith bounding box. +box :: Int -> StaticModelResource -> Box +box i model = boxes model V.! i + +-- | Get the renderer's model resource. +modelRes :: StaticModelRenderer -> StaticModelResource +modelRes = model + +-- | Bind the given renderer to prepare it for rendering. +bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () +bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = + let (Material _ ka kd ks shi) = material model + in do + bindVAO . vao $ model + bindTexture $ texture model + activeTexture $= gl_TEXTURE0 + glUniform1i texLoc 0 + +-- | Render the given renderer. +render :: StaticProgramUniforms -> StaticModelRenderer -> IO () +render uniforms (StaticModelRenderer model) = + let (Material _ ka kd ks shi) = material model + in do + uniform (kaLoc uniforms) ka + uniform (kdLoc uniforms) kd + uniform (ksLoc uniforms) ks + glUniform1f (shiLoc uniforms) $ unsafeCoerce shi + drawArrays gl_TRIANGLES 0 $ nVertices model + +-- | Compute AABB collisioners in view space from the given model. +mkColsFromStatic + :: Matrix4 -- ^ Modelview matrix + -> StaticModelResource + -> [Collisioner2] +mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) diff --git a/Spear/Render/Triangle.hs b/Spear/Render/Triangle.hs index 08a2c01..49f4418 100644 --- a/Spear/Render/Triangle.hs +++ b/Spear/Render/Triangle.hs @@ -1,8 +1,8 @@ -module Spear.Render.Triangle -( -) -where - - -import Spear.GL - +module Spear.Render.Triangle +( +) +where + + +import Spear.GL + 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 @@ -module Spear.Scene.GameObject -( - GameObject -, GameStyle(..) -, Window(..) -, AM.AnimationSpeed - -- * Construction -, goNew - -- * Accessors -, currentAnimation ---, goAABB ---, goAABBs -, collisioners -, goRPGtransform -, numCollisioners -, renderer -, window - -- * Manipulation -, goUpdate -, setAnimation -, setAnimationSpeed -, setAxis -, withCollisioners -, setCollisioners -, setWindow - -- * Rendering -, goRender - -- * Collision -, goCollide -) -where - - -import Spear.GL -import Spear.Math.AABB -import qualified Spear.Math.Camera as Cam -import Spear.Math.Collision as Col -import qualified Spear.Math.Matrix3 as M3 -import qualified Spear.Math.Matrix4 as M4 -import Spear.Math.MatrixUtils -import qualified Spear.Math.Spatial2 as S2 -import qualified Spear.Math.Spatial3 as S3 -import Spear.Math.Utils -import Spear.Math.Vector -import qualified Spear.Render.AnimatedModel as AM -import Spear.Render.Program -import Spear.Render.StaticModel as SM - -import Data.Fixed (mod') -import Data.List (foldl') - - --- | Game style. -data GameStyle - = RPG -- ^ RPG or RTS style game. - | PLT -- ^ Platformer or space invaders style game. - - -data Window = Window - { projInv :: !M4.Matrix4 - , viewInv :: !M4.Matrix4 - , vpx :: !Float - , vpy :: !Float - , width :: !Float - , height :: !Float - } - - -dummyWindow = Window M4.id M4.id 0 0 640 480 - - --- | An object in the game scene. -data GameObject = GameObject - { gameStyle :: !GameStyle - , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) - , collisioners :: ![Collisioner2] - , transform :: !M3.Matrix3 - , axis :: !Vector3 - , angle :: !Float - , window :: !Window - } - - -instance S2.Spatial2 GameObject where - - move v go = go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * transform go - } - - moveFwd s go = - let m = transform go - v = scale s $ M3.forward m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - moveBack s go = - let m = transform go - v = scale (-s) $ M3.forward m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - strafeLeft s go = - let m = transform go - v = scale (-s) $ M3.right m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - strafeRight s go = - let m = transform go - v = scale s $ M3.right m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - rotate a go = - go - { transform = transform go * M3.rot a - , angle = (angle go + a) `mod'` 360 - } - - setRotation a go = - go - { transform = M3.translation (transform go) * M3.rot a - , angle = a - } - - pos go = M3.position . transform $ go - - fwd go = M3.forward . transform $ go - - up go = M3.up . transform $ go - - right go = M3.right . transform $ go - - transform go = Spear.Scene.GameObject.transform go - - setTransform mat go = go { transform = mat } - - setPos pos go = - let m = transform go - in go { transform = M3.transform (M3.right m) (M3.forward m) pos } - - lookAt p go = - let position = S2.pos go - fwd = normalise $ p - position - r = perp fwd - toDeg = (*(180/pi)) - viewI = viewInv . window $ go - p1 = viewToWorld2d position viewI - p2 = viewToWorld2d (position + fwd) viewI - f = normalise $ p2 - p1 - in - go - { transform = M3.transform r fwd position - , angle = 180 - - if x f > 0 - then toDeg . acos $ f `dot` unity2 - else (+180) . toDeg . acos $ f `dot` (-unity2) - } - - --- | Create a new game object. -goNew :: GameStyle - -> Either StaticModelResource AM.AnimatedModelResource - -> [Collisioner2] - -> M3.Matrix3 -- ^ Transform - -> Vector3 -- ^ Axis of rotation - -> GameObject - -goNew style (Left smr) cols transf axis = GameObject - style (Left $ SM.staticModelRenderer smr) cols transf axis 0 dummyWindow - -goNew style (Right amr) cols transf axis = GameObject - style (Right $ AM.animatedModelRenderer 1 amr) cols transf axis 0 dummyWindow - - -goUpdate :: Float -> GameObject -> GameObject -goUpdate dt go = - let rend = renderer go - rend' = case rend of - Left _ -> rend - Right amr -> Right $ AM.update dt amr - in go - { renderer = rend' - } - - --- | Get the game object's ith bounding box. ---goAABB :: Int -> GameObject -> AABB2 ---goAABB i = getAABB . flip (!!) i . collisioners - - --- | Get the game object's bounding boxes. ---goAABBs :: GameObject -> [AABB2] ---goAABBs = fmap getAABB . collisioners - - --- | Get the game object's 3D transform. -goRPGtransform :: GameObject -> M4.Matrix4 -goRPGtransform go = - let viewI = viewInv . window $ go - in rpgTransform 0 (angle go) (axis go) (S2.pos go) viewI - - --- | Get the game object's current animation. -currentAnimation :: Enum a => GameObject -> a -currentAnimation go = case renderer go of - Left _ -> toEnum 0 - Right amr -> AM.currentAnimation amr - - --- | Return the game object's number of collisioners. -numCollisioners :: GameObject -> Int -numCollisioners = length . collisioners - - --- | Set the game object's current animation. -setAnimation :: Enum a => a -> GameObject -> GameObject -setAnimation a go = case renderer go of - Left _ -> go - Right amr -> go { renderer = Right $ AM.setAnimation a amr } - - --- | Set the game object's animation speed. -setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject -setAnimationSpeed s go = case renderer go of - Left _ -> go - Right amr -> go { renderer = Right $ AM.setAnimationSpeed s amr } - - --- | Set the game object's axis of rotation. -setAxis :: Vector3 -> GameObject -> GameObject -setAxis ax go = go { axis = ax } - - --- | Set the game object's collisioners. -setCollisioners :: [Collisioner2] -> GameObject -> GameObject -setCollisioners cols go = go { collisioners = cols } - - --- | Set the game object's window. -setWindow :: Window -> GameObject -> GameObject -setWindow wnd go = go { window = wnd } - - --- | Manipulate the game object's collisioners. -withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject -withCollisioners go f = go { collisioners = f $ collisioners go } - - --- | Render the game object. -goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO () -goRender sprog aprog cam go = - let spu = staticProgramUniforms sprog - apu = animatedProgramUniforms aprog - style = gameStyle go - axis' = axis go - a = angle go - proj = Cam.projection cam - view = M4.inverseTransform $ S3.transform cam - transf = S2.transform go - normal = fastNormalMatrix modelview - modelview = case style of - RPG -> view * goRPGtransform go - PLT -> view * pltTransform transf - in case renderer go of - Left smr -> - goRender' style a axis' sprog spu modelview proj normal - (SM.bind spu smr) (SM.render spu smr) - Right amr -> - goRender' style a axis' aprog apu modelview proj normal - (AM.bind apu amr) (AM.render apu amr) - - -type Bind = IO () - -type Render = IO () - - -goRender' :: (ProgramUniforms u, Program p) - => GameStyle - -> Float - -> Vector3 - -> p - -> u - -> M4.Matrix4 -- Modelview - -> M4.Matrix4 -- Projection - -> M3.Matrix3 -- Normal matrix - -> Bind - -> Render - -> IO () -goRender' style a axis prog uniforms modelview proj normal bindRenderer render = - let - in do - useProgram . program $ prog - uniform (projLoc uniforms) proj - uniform (modelviewLoc uniforms) modelview - uniform (normalmatLoc uniforms) normal - bindRenderer - render - - --- | Return 'True' if the given game objects collide, 'False' otherwise. -goCollide :: GameObject -> GameObject -> Bool -goCollide go1 go2 = - let cols1 = collisioners go1 - cols2 = collisioners go2 - c1 = cols1 !! 0 - c2 = cols2 !! 0 - in - if length cols1 == 0 || length cols2 == 0 then False - else c1 `collide` c2 /= NoCollision +module Spear.Scene.GameObject +( + GameObject +, GameStyle(..) +, Window(..) +, AM.AnimationSpeed + -- * Construction +, goNew + -- * Accessors +, currentAnimation +--, goAABB +--, goAABBs +, collisioners +, goRPGtransform +, numCollisioners +, renderer +, window + -- * Manipulation +, goUpdate +, setAnimation +, setAnimationSpeed +, setAxis +, withCollisioners +, setCollisioners +, setWindow + -- * Rendering +, goRender + -- * Collision +, goCollide +) +where + + +import Spear.GL +import Spear.Math.AABB +import qualified Spear.Math.Camera as Cam +import Spear.Math.Collision as Col +import qualified Spear.Math.Matrix3 as M3 +import qualified Spear.Math.Matrix4 as M4 +import Spear.Math.MatrixUtils +import qualified Spear.Math.Spatial2 as S2 +import qualified Spear.Math.Spatial3 as S3 +import Spear.Math.Utils +import Spear.Math.Vector +import qualified Spear.Render.AnimatedModel as AM +import Spear.Render.Program +import Spear.Render.StaticModel as SM + +import Data.Fixed (mod') +import Data.List (foldl') + + +-- | Game style. +data GameStyle + = RPG -- ^ RPG or RTS style game. + | PLT -- ^ Platformer or space invaders style game. + + +data Window = Window + { projInv :: !M4.Matrix4 + , viewInv :: !M4.Matrix4 + , vpx :: !Float + , vpy :: !Float + , width :: !Float + , height :: !Float + } + + +dummyWindow = Window M4.id M4.id 0 0 640 480 + + +-- | An object in the game scene. +data GameObject = GameObject + { gameStyle :: !GameStyle + , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) + , collisioners :: ![Collisioner2] + , transform :: !M3.Matrix3 + , axis :: !Vector3 + , angle :: !Float + , window :: !Window + } + + +instance S2.Spatial2 GameObject where + + move v go = go + { collisioners = fmap (Col.move v) $ collisioners go + , transform = M3.translv v * transform go + } + + moveFwd s go = + let m = transform go + v = scale s $ M3.forward m + in go + { collisioners = fmap (Col.move v) $ collisioners go + , transform = M3.translv v * m + } + + moveBack s go = + let m = transform go + v = scale (-s) $ M3.forward m + in go + { collisioners = fmap (Col.move v) $ collisioners go + , transform = M3.translv v * m + } + + strafeLeft s go = + let m = transform go + v = scale (-s) $ M3.right m + in go + { collisioners = fmap (Col.move v) $ collisioners go + , transform = M3.translv v * m + } + + strafeRight s go = + let m = transform go + v = scale s $ M3.right m + in go + { collisioners = fmap (Col.move v) $ collisioners go + , transform = M3.translv v * m + } + + rotate a go = + go + { transform = transform go * M3.rot a + , angle = (angle go + a) `mod'` 360 + } + + setRotation a go = + go + { transform = M3.translation (transform go) * M3.rot a + , angle = a + } + + pos go = M3.position . transform $ go + + fwd go = M3.forward . transform $ go + + up go = M3.up . transform $ go + + right go = M3.right . transform $ go + + transform go = Spear.Scene.GameObject.transform go + + setTransform mat go = go { transform = mat } + + setPos pos go = + let m = transform go + in go { transform = M3.transform (M3.right m) (M3.forward m) pos } + + lookAt p go = + let position = S2.pos go + fwd = normalise $ p - position + r = perp fwd + toDeg = (*(180/pi)) + viewI = viewInv . window $ go + p1 = viewToWorld2d position viewI + p2 = viewToWorld2d (position + fwd) viewI + f = normalise $ p2 - p1 + in + go + { transform = M3.transform r fwd position + , angle = 180 - + if x f > 0 + then toDeg . acos $ f `dot` unity2 + else (+180) . toDeg . acos $ f `dot` (-unity2) + } + + +-- | Create a new game object. +goNew :: GameStyle + -> Either StaticModelResource AM.AnimatedModelResource + -> [Collisioner2] + -> M3.Matrix3 -- ^ Transform + -> Vector3 -- ^ Axis of rotation + -> GameObject + +goNew style (Left smr) cols transf axis = GameObject + style (Left $ SM.staticModelRenderer smr) cols transf axis 0 dummyWindow + +goNew style (Right amr) cols transf axis = GameObject + style (Right $ AM.animatedModelRenderer 1 amr) cols transf axis 0 dummyWindow + + +goUpdate :: Float -> GameObject -> GameObject +goUpdate dt go = + let rend = renderer go + rend' = case rend of + Left _ -> rend + Right amr -> Right $ AM.update dt amr + in go + { renderer = rend' + } + + +-- | Get the game object's ith bounding box. +--goAABB :: Int -> GameObject -> AABB2 +--goAABB i = getAABB . flip (!!) i . collisioners + + +-- | Get the game object's bounding boxes. +--goAABBs :: GameObject -> [AABB2] +--goAABBs = fmap getAABB . collisioners + + +-- | Get the game object's 3D transform. +goRPGtransform :: GameObject -> M4.Matrix4 +goRPGtransform go = + let viewI = viewInv . window $ go + in rpgTransform 0 (angle go) (axis go) (S2.pos go) viewI + + +-- | Get the game object's current animation. +currentAnimation :: Enum a => GameObject -> a +currentAnimation go = case renderer go of + Left _ -> toEnum 0 + Right amr -> AM.currentAnimation amr + + +-- | Return the game object's number of collisioners. +numCollisioners :: GameObject -> Int +numCollisioners = length . collisioners + + +-- | Set the game object's current animation. +setAnimation :: Enum a => a -> GameObject -> GameObject +setAnimation a go = case renderer go of + Left _ -> go + Right amr -> go { renderer = Right $ AM.setAnimation a amr } + + +-- | Set the game object's animation speed. +setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject +setAnimationSpeed s go = case renderer go of + Left _ -> go + Right amr -> go { renderer = Right $ AM.setAnimationSpeed s amr } + + +-- | Set the game object's axis of rotation. +setAxis :: Vector3 -> GameObject -> GameObject +setAxis ax go = go { axis = ax } + + +-- | Set the game object's collisioners. +setCollisioners :: [Collisioner2] -> GameObject -> GameObject +setCollisioners cols go = go { collisioners = cols } + + +-- | Set the game object's window. +setWindow :: Window -> GameObject -> GameObject +setWindow wnd go = go { window = wnd } + + +-- | Manipulate the game object's collisioners. +withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject +withCollisioners go f = go { collisioners = f $ collisioners go } + + +-- | Render the game object. +goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO () +goRender sprog aprog cam go = + let spu = staticProgramUniforms sprog + apu = animatedProgramUniforms aprog + style = gameStyle go + axis' = axis go + a = angle go + proj = Cam.projection cam + view = M4.inverseTransform $ S3.transform cam + transf = S2.transform go + normal = fastNormalMatrix modelview + modelview = case style of + RPG -> view * goRPGtransform go + PLT -> view * pltTransform transf + in case renderer go of + Left smr -> + goRender' style a axis' sprog spu modelview proj normal + (SM.bind spu smr) (SM.render spu smr) + Right amr -> + goRender' style a axis' aprog apu modelview proj normal + (AM.bind apu amr) (AM.render apu amr) + + +type Bind = IO () + +type Render = IO () + + +goRender' :: (ProgramUniforms u, Program p) + => GameStyle + -> Float + -> Vector3 + -> p + -> u + -> M4.Matrix4 -- Modelview + -> M4.Matrix4 -- Projection + -> M3.Matrix3 -- Normal matrix + -> Bind + -> Render + -> IO () +goRender' style a axis prog uniforms modelview proj normal bindRenderer render = + let + in do + useProgram . program $ prog + uniform (projLoc uniforms) proj + uniform (modelviewLoc uniforms) modelview + uniform (normalmatLoc uniforms) normal + bindRenderer + render + + +-- | Return 'True' if the given game objects collide, 'False' otherwise. +goCollide :: GameObject -> GameObject -> Bool +goCollide go1 go2 = + let cols1 = collisioners go1 + cols2 = collisioners go2 + c1 = cols1 !! 0 + c2 = cols2 !! 0 + in + if length cols1 == 0 || length cols2 == 0 then False + 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 @@ -module Spear.Scene.Graph -( - Property -, SceneGraph(..) -, ParseError -, loadSceneGraph -, loadSceneGraphFromFile -, node -) -where - - -import qualified Data.ByteString.Char8 as B -import Data.List (find, intersperse) -import Data.Maybe (isJust) -import Text.Parsec.Char -import Text.Parsec.Combinator -import Text.Parsec.Error -import Text.Parsec.Prim -import qualified Text.Parsec.ByteString as P -import qualified Text.Parsec.Token as PT - - -type Property = (String, [String]) - - -data SceneGraph - = SceneNode - { nodeID :: String - , properties :: [Property] - , children :: [SceneGraph] - } - | SceneLeaf - { nodeID :: String - , properties :: [Property] - } - - -instance Show SceneGraph where - show sceneGraph = show' "" sceneGraph - where - show' tab (SceneNode nid props children) = - tab ++ nid ++ "\n" ++ tab ++ "{\n" ++ (printProps tab props) ++ - (concat . fmap (show' $ " " ++ tab) $ children) ++ '\n':tab ++ "}\n" - - show' tab (SceneLeaf nid props) = - tab ++ nid ++ '\n':tab ++ "{\n" ++ tab ++ (printProps tab props) ++ '\n':tab ++ "}\n" - - -printProp :: Property -> String -printProp (key, vals) = key ++ " = " ++ (concat $ intersperse ", " vals) - - -printProps :: String -> [Property] -> String -printProps tab props = - let - tab' = '\n':(tab ++ tab) - longestKeyLen = maximum . fmap (length . fst) $ props - - align :: Int -> String -> String - align len str = - let (key, vals) = break ((==) '=') str - thisLen = length key - padLen = len - thisLen + 1 - pad = replicate padLen ' ' - in - key ++ pad ++ vals - in - case concat . intersperse tab' . fmap (align longestKeyLen . printProp) $ props of - [] -> [] - xs -> tab ++ xs - - --- | Load the scene graph from the given string. -loadSceneGraph :: String -> Either ParseError SceneGraph -loadSceneGraph str = parse sceneGraph "(unknown)" $ B.pack str - - --- | Load the scene graph specified by the given file. -loadSceneGraphFromFile :: FilePath -> IO (Either ParseError SceneGraph) -loadSceneGraphFromFile = P.parseFromFile sceneGraph - - --- | Get the node identified by the given string from the given scene graph. -node :: String -> SceneGraph -> Maybe SceneGraph -node str SceneLeaf {} = Nothing -node str n@(SceneNode nid _ children) - | str == nid = Just n - | otherwise = case find isJust $ fmap (node str) children of - Nothing -> Nothing - Just x -> x - - -sceneGraph :: P.Parser SceneGraph -sceneGraph = do - g <- graph - whitespace - eof - return g - - -graph :: P.Parser SceneGraph -graph = do - nid <- name - whitespace - char '{' - props <- many . try $ whitespace >> property - children <- many . try $ whitespace >> graph - whitespace - char '}' - - return $ case null children of - True -> SceneLeaf nid props - False -> SceneNode nid props children - - -property :: P.Parser Property -property = do - key <- name - spaces >> char '=' >> spaces - vals <- cells name - return (key, vals) - - -cells :: P.Parser String -> P.Parser [String] -cells p = do - val <- p - vals <- remainingCells p - return $ val:vals - - -remainingCells :: P.Parser String -> P.Parser [String] -remainingCells p = - try (whitespace >> char ',' >> whitespace >> cells p) - <|> (return []) - - -name :: P.Parser String -name = many1 $ choice [oneOf "-/.()?_", alphaNum] - - -whitespace :: P.Parser () -whitespace = skipMany $ choice [space, newline] +module Spear.Scene.Graph +( + Property +, SceneGraph(..) +, ParseError +, loadSceneGraph +, loadSceneGraphFromFile +, node +) +where + + +import qualified Data.ByteString.Char8 as B +import Data.List (find, intersperse) +import Data.Maybe (isJust) +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.Parsec.Error +import Text.Parsec.Prim +import qualified Text.Parsec.ByteString as P +import qualified Text.Parsec.Token as PT + + +type Property = (String, [String]) + + +data SceneGraph + = SceneNode + { nodeID :: String + , properties :: [Property] + , children :: [SceneGraph] + } + | SceneLeaf + { nodeID :: String + , properties :: [Property] + } + + +instance Show SceneGraph where + show sceneGraph = show' "" sceneGraph + where + show' tab (SceneNode nid props children) = + tab ++ nid ++ "\n" ++ tab ++ "{\n" ++ (printProps tab props) ++ + (concat . fmap (show' $ " " ++ tab) $ children) ++ '\n':tab ++ "}\n" + + show' tab (SceneLeaf nid props) = + tab ++ nid ++ '\n':tab ++ "{\n" ++ tab ++ (printProps tab props) ++ '\n':tab ++ "}\n" + + +printProp :: Property -> String +printProp (key, vals) = key ++ " = " ++ (concat $ intersperse ", " vals) + + +printProps :: String -> [Property] -> String +printProps tab props = + let + tab' = '\n':(tab ++ tab) + longestKeyLen = maximum . fmap (length . fst) $ props + + align :: Int -> String -> String + align len str = + let (key, vals) = break ((==) '=') str + thisLen = length key + padLen = len - thisLen + 1 + pad = replicate padLen ' ' + in + key ++ pad ++ vals + in + case concat . intersperse tab' . fmap (align longestKeyLen . printProp) $ props of + [] -> [] + xs -> tab ++ xs + + +-- | Load the scene graph from the given string. +loadSceneGraph :: String -> Either ParseError SceneGraph +loadSceneGraph str = parse sceneGraph "(unknown)" $ B.pack str + + +-- | Load the scene graph specified by the given file. +loadSceneGraphFromFile :: FilePath -> IO (Either ParseError SceneGraph) +loadSceneGraphFromFile = P.parseFromFile sceneGraph + + +-- | Get the node identified by the given string from the given scene graph. +node :: String -> SceneGraph -> Maybe SceneGraph +node str SceneLeaf {} = Nothing +node str n@(SceneNode nid _ children) + | str == nid = Just n + | otherwise = case find isJust $ fmap (node str) children of + Nothing -> Nothing + Just x -> x + + +sceneGraph :: P.Parser SceneGraph +sceneGraph = do + g <- graph + whitespace + eof + return g + + +graph :: P.Parser SceneGraph +graph = do + nid <- name + whitespace + char '{' + props <- many . try $ whitespace >> property + children <- many . try $ whitespace >> graph + whitespace + char '}' + + return $ case null children of + True -> SceneLeaf nid props + False -> SceneNode nid props children + + +property :: P.Parser Property +property = do + key <- name + spaces >> char '=' >> spaces + vals <- cells name + return (key, vals) + + +cells :: P.Parser String -> P.Parser [String] +cells p = do + val <- p + vals <- remainingCells p + return $ val:vals + + +remainingCells :: P.Parser String -> P.Parser [String] +remainingCells p = + try (whitespace >> char ',' >> whitespace >> cells p) + <|> (return []) + + +name :: P.Parser String +name = many1 $ choice [oneOf "-/.()?_", alphaNum] + + +whitespace :: P.Parser () +whitespace = skipMany $ choice [space, newline] diff --git a/Spear/Scene/Light.hs b/Spear/Scene/Light.hs index f63b91d..fb4225b 100644 --- a/Spear/Scene/Light.hs +++ b/Spear/Scene/Light.hs @@ -1,31 +1,31 @@ -module Spear.Scene.Light -( - Light(..) -) -where - - -import qualified Spear.Math.Matrix4 as M -import qualified Spear.Math.Spatial3 as S -import Spear.Math.Vector - - -data Light - = PointLight - { ambient :: Vector3 - , diffuse :: Vector3 - , specular :: Vector3 - , transform :: M.Matrix4 - } - | DirectionalLight - { ambient :: Vector3 - , diffuse :: Vector3 - , specular :: Vector3 - , direction :: Vector3 - } - | SpotLight - { ambient :: Vector3 - , diffuse :: Vector3 - , specular :: Vector3 - , transform :: M.Matrix4 - } +module Spear.Scene.Light +( + Light(..) +) +where + + +import qualified Spear.Math.Matrix4 as M +import qualified Spear.Math.Spatial3 as S +import Spear.Math.Vector + + +data Light + = PointLight + { ambient :: Vector3 + , diffuse :: Vector3 + , specular :: Vector3 + , transform :: M.Matrix4 + } + | DirectionalLight + { ambient :: Vector3 + , diffuse :: Vector3 + , specular :: Vector3 + , direction :: Vector3 + } + | SpotLight + { ambient :: Vector3 + , diffuse :: Vector3 + , specular :: Vector3 + , transform :: M.Matrix4 + } 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 @@ -module Spear.Scene.Loader -( - SceneResources(..) -, CreateGameObject -, loadScene -, validate -, resourceMap -, loadGO -, loadObjects -, value -, unspecified -, mandatory -, asString -, asFloat -, asVec3 -, asVec4 -) -where - -import Spear.Assets.Model as Model -import Spear.Game -import qualified Spear.GL as GL -import Spear.Math.Collision -import Spear.Math.Matrix3 as M3 -import Spear.Math.Matrix4 as M4 -import Spear.Math.MatrixUtils (fastNormalMatrix) -import Spear.Math.Vector -import Spear.Render.AnimatedModel as AM -import Spear.Render.Material -import Spear.Render.Program -import Spear.Render.StaticModel as SM -import Spear.Scene.GameObject as GO -import Spear.Scene.Graph -import Spear.Scene.Light -import Spear.Scene.SceneResources - -import Control.Monad.State.Strict -import Control.Monad.Trans (lift) -import Data.List as L (find) -import Data.Map as M -import qualified Data.StateVar as SV (get) -import Text.Printf (printf) - -type Loader = Game SceneResources - --- | Load the scene specified by the given file. -loadScene :: FilePath -> Game s (SceneResources, SceneGraph) -loadScene file = do - result <- gameIO $ loadSceneGraphFromFile file - case result of - Left err -> gameError $ show err - Right g -> case validate g of - Nothing -> do - sceneRes <- resourceMap g - return (sceneRes, g) - Just err -> gameError err - --- | Validate the given SceneGraph. -validate :: SceneGraph -> Maybe String -validate _ = Nothing - --- | Load the scene described by the given 'SceneGraph'. -resourceMap :: SceneGraph -> Game s SceneResources -resourceMap g = execSubGame (resourceMap' g) emptySceneResources - -resourceMap' :: SceneGraph -> Loader () -resourceMap' node@(SceneLeaf nid props) = do - case nid of - "shader-program" -> newShaderProgram node - "model" -> newModel node - "light" -> newLight node - x -> return () - -resourceMap' node@(SceneNode nid props children) = do - mapM_ resourceMap' children - --- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it. -loadResource :: String -- ^ Resource name. - -> (SceneResources -> Map String a) -- ^ Map getter. - -> (String -> a -> Loader ()) -- ^ Function to modify resources. - -> Loader a -- ^ Resource loader. - -> Loader a -loadResource key field modifyResources load = do - sceneData <- get - case M.lookup key $ field sceneData of - Just val -> return val - Nothing -> do - gameIO $ printf "Loading %s..." key - resource <- load - gameIO $ printf "done\n" - modifyResources key resource - return resource - -addShader name shader = modify $ \sceneData -> - sceneData { shaders = M.insert name shader $ shaders sceneData } - -addCustomProgram name prog = modify $ \sceneData -> - sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } - -addStaticProgram name prog = modify $ \sceneData -> - sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } - -addAnimatedProgram name prog = modify $ \sceneData -> - sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } - -addTexture name tex = modify $ \sceneData -> - sceneData { textures = M.insert name tex $ textures sceneData } - -addStaticModel name model = modify $ - \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData } - -addAnimatedModel name model = modify $ - \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData } - --- Get the given resource from the data pool. -getResource :: (SceneResources -> Map String a) -> String -> Loader a -getResource field key = do - sceneData <- get - case M.lookup key $ field sceneData of - Just val -> return val - Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key - ----------------------- --- Resource Loading -- ----------------------- - -newModel :: SceneGraph -> Loader () -newModel (SceneLeaf _ props) = do - name <- asString $ mandatory' "name" props - file <- asString $ mandatory' "file" props - tex <- asString $ mandatory' "texture" props - prog <- asString $ mandatory' "shader-program" props - ke <- asVec4 $ mandatory' "ke" props - ka <- asVec4 $ mandatory' "ka" props - kd <- asVec4 $ mandatory' "kd" props - ks <- asVec4 $ mandatory' "ks" props - shi <- asFloat $ mandatory' "shi" props - - let rotation = asRotation $ value "rotation" props - scale = asVec3 $ value "scale" props - - gameIO $ printf "Loading model %s..." name - model <- loadModel' file rotation scale - gameIO . putStrLn $ "done" - texture <- loadTexture tex - sceneRes <- get - - let material = Material ke ka kd ks shi - - case animated model of - False -> - case M.lookup prog $ staticPrograms sceneRes of - Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return () - Just p -> - let StaticProgram _ channels _ = p - in do - model' <- staticModelResource channels material texture model - loadResource name staticModels addStaticModel (return model') - return () - True -> - case M.lookup prog $ animatedPrograms sceneRes of - Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return () - Just p -> - let AnimatedProgram _ channels _ = p - in do - model' <- animatedModelResource channels material texture model - loadResource name animatedModels addAnimatedModel (return model') - return () - -loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model -loadModel' file rotation scale = do - let transform = - (case rotation of - Nothing -> Prelude.id - Just rot -> rotateModel rot) . - - (case scale of - Nothing -> Prelude.id - Just s -> flip Model.transformVerts $ - \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')) - - (fmap transform $ Model.loadModel file) >>= gameIO . toGround - -rotateModel :: Rotation -> Model -> Model -rotateModel (Rotation ax ay az order) model = - let mat = case order of - XYZ -> rotZ az * rotY ay * rotX ax - XZY -> rotY ay * rotZ az * rotX ax - YXZ -> rotZ az * rotX ax * rotY ay - YZX -> rotX ax * rotZ az * rotY ay - ZXY -> rotY ay * rotX ax * rotZ az - ZYX -> rotX ax * rotY ay * rotZ az - normalMat = fastNormalMatrix mat - - vTransform (Vec3 x' y' z') = - let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) - - nTransform (Vec3 x' y' z') = - let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) - in - flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model - -loadTexture :: FilePath -> Loader GL.Texture -loadTexture file = - loadResource file textures addTexture $ - GL.loadTextureImage file GL.gl_LINEAR GL.gl_LINEAR - -newShaderProgram :: SceneGraph -> Loader () -newShaderProgram (SceneLeaf _ props) = do - (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props - (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props - name <- asString $ mandatory' "name" props - stype <- asString $ mandatory' "type" props - prog <- GL.newProgram [vertShader, fragShader] - - let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name - - case stype of - "static" -> do - ambient <- asString $ mandatory' "ambient" props - diffuse <- asString $ mandatory' "diffuse" props - specular <- asString $ mandatory' "specular" props - shininess <- asString $ mandatory' "shininess" props - texture <- asString $ mandatory' "texture" props - modelview <- asString $ mandatory' "modelview" props - normalmat <- asString $ mandatory' "normalmat" props - projection <- asString $ mandatory' "projection" props - - ka <- getUniformLoc ambient - kd <- getUniformLoc diffuse - ks <- getUniformLoc specular - shi <- getUniformLoc shininess - tex <- getUniformLoc texture - mview <- getUniformLoc modelview - nmat <- getUniformLoc normalmat - proj <- getUniformLoc projection - - vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props - normChan <- fmap read $ asString $ mandatory' "normal-channel" props - texChan <- fmap read $ asString $ mandatory' "texture-channel" props - - let channels = StaticProgramChannels vertChan normChan texChan - uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj - - loadResource name staticPrograms addStaticProgram $ - return $ StaticProgram prog channels uniforms - return () - - "animated" -> do - ambient <- asString $ mandatory' "ambient" props - diffuse <- asString $ mandatory' "diffuse" props - specular <- asString $ mandatory' "specular" props - shininess <- asString $ mandatory' "shininess" props - texture <- asString $ mandatory' "texture" props - modelview <- asString $ mandatory' "modelview" props - normalmat <- asString $ mandatory' "normalmat" props - projection <- asString $ mandatory' "projection" props - - ka <- getUniformLoc ambient - kd <- getUniformLoc diffuse - ks <- getUniformLoc specular - shi <- getUniformLoc shininess - tex <- getUniformLoc texture - mview <- getUniformLoc modelview - nmat <- getUniformLoc normalmat - proj <- getUniformLoc projection - - vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props - vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props - normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props - normChan2 <- fmap read $ asString $ mandatory' "normal-channel2" props - texChan <- fmap read $ asString $ mandatory' "texture-channel" props - fp <- asString $ mandatory' "fp" props - p <- getUniformLoc fp - - let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan - uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj - - loadResource name animatedPrograms addAnimatedProgram $ - return $ AnimatedProgram prog channels uniforms - return () - - _ -> do - loadResource name customPrograms addCustomProgram $ return prog - return () - -loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) -loadShader _ [] = gameError $ "Loader::vertexShader: empty list" -loadShader shaderType ((stype, file):xs) = - if shaderType == GL.VertexShader && stype == "vertex-shader" || - shaderType == GL.FragmentShader && stype == "fragment-shader" - then let f = concat file - in loadShader' f shaderType >>= \shader -> return (f, shader) - else Spear.Scene.Loader.loadShader shaderType xs - -loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader -loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file - -newLight :: SceneGraph -> Loader () -newLight _ = return () - --------------------- --- Object Loading -- --------------------- - -loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject -loadGO style sceneRes props transf = do - modelName <- asString . mandatory "model" $ props - axis <- asVec3 . mandatory "axis" $ props - let animSpeed = asFloat . value "animation-speed" $ props - go <- case getAnimatedModel sceneRes modelName of - Just model -> - return $ goNew style (Right model) [] transf axis - Nothing -> - case getStaticModel sceneRes modelName of - Just model -> - return $ goNew style (Left model) [] transf axis - Nothing -> - gameError $ "model " ++ modelName ++ " not found" - return $ case animSpeed of - Nothing -> go - Just s -> GO.setAnimationSpeed s go - -type CreateGameObject m a - = String -- ^ The object's name. - -> SceneResources - -> [Property] - -> Matrix3 -- ^ The object's transform. - -> m a - --- | Load objects from the given 'SceneGraph'. -loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] -loadObjects newGO sceneRes g = - case node "layout" g of - Nothing -> return [] - Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n - --- to-do: use a strict accumulator and make loadObjects tail recursive. -newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] -newObject newGO sceneRes (SceneNode nid props children) = - let o = newObject' newGO sceneRes nid props - in o : (concat $ fmap (newObject newGO sceneRes) children) - -newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] - -newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a -newObject' newGO sceneRes nid props = do - -- Optional properties. - let goType = (asString $ value "type" props) `unspecified` "unknown" - position = (asVec2 $ value "position" props) `unspecified` vec2 0 0 - rotation = (asVec2 $ value "rotation" props) `unspecified` vec2 0 0 - right' = (asVec2 $ value "right" props) `unspecified` vec2 1 0 - up' = asVec2 $ value "up" props - scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1 - - -- Compute the object's vectors if an up/forward vector has been specified. - let (right, up) = vectors up' - - newGO goType sceneRes props (M3.transform right up position) - -vectors :: Maybe Vector2 -> (Vector2, Vector2) -vectors up = case up of - Nothing -> (unitx2, unity2) - Just u -> (perp u, u) - ----------------------- --- Helper functions -- ----------------------- - --- Get the value of the given key. -value :: String -> [Property] -> Maybe [String] -value name props = case L.find ((==) name . fst) props of - Nothing -> Nothing - Just prop -> Just . snd $ prop - -unspecified :: Maybe a -> a -> a -unspecified (Just x) _ = x -unspecified Nothing x = x - -mandatory :: String -> [Property] -> Game s [String] -mandatory name props = case value name props of - Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name - Just x -> return x - -mandatory' :: String -> [Property] -> Loader [String] -mandatory' name props = mandatory name props - -asString :: Functor f => f [String] -> f String -asString = fmap concat - -asFloat :: Functor f => f [String] -> f Float -asFloat = fmap (read . concat) - -asVec2 :: Functor f => f [String] -> f Vector2 -asVec2 val = fmap toVec2 val - where toVec2 (x:y:_) = vec2 (read x) (read y) - toVec2 (x:[]) = let x' = read x in vec2 x' x' - -asVec3 :: Functor f => f [String] -> f Vector3 -asVec3 val = fmap toVec3 val - where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z) - toVec3 (x:[]) = let x' = read x in vec3 x' x' x' - -asVec4 :: Functor f => f [String] -> f Vector4 -asVec4 val = fmap toVec4 val - where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w) - toVec4 (x:[]) = let x' = read x in vec4 x' x' x' x' - -asRotation :: Functor f => f [String] -> f Rotation -asRotation val = fmap parseRotation val - where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order) - -data Rotation = Rotation - { ax :: Float - , ay :: Float - , az :: Float - , order :: RotationOrder - } - -data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq - -readOrder :: String -> RotationOrder -readOrder "xyz" = XYZ -readOrder "xzy" = XZY -readOrder "yxz" = YXZ -readOrder "yzx" = YZX -readOrder "zxy" = ZXY -readOrder "zyx" = ZYX +module Spear.Scene.Loader +( + SceneResources(..) +, CreateGameObject +, loadScene +, validate +, resourceMap +, loadGO +, loadObjects +, value +, unspecified +, mandatory +, asString +, asFloat +, asVec3 +, asVec4 +) +where + +import Spear.Assets.Model as Model +import Spear.Game +import qualified Spear.GL as GL +import Spear.Math.Collision +import Spear.Math.Matrix3 as M3 +import Spear.Math.Matrix4 as M4 +import Spear.Math.MatrixUtils (fastNormalMatrix) +import Spear.Math.Vector +import Spear.Render.AnimatedModel as AM +import Spear.Render.Material +import Spear.Render.Program +import Spear.Render.StaticModel as SM +import Spear.Scene.GameObject as GO +import Spear.Scene.Graph +import Spear.Scene.Light +import Spear.Scene.SceneResources + +import Control.Monad.State.Strict +import Control.Monad.Trans (lift) +import Data.List as L (find) +import Data.Map as M +import qualified Data.StateVar as SV (get) +import Text.Printf (printf) + +type Loader = Game SceneResources + +-- | Load the scene specified by the given file. +loadScene :: FilePath -> Game s (SceneResources, SceneGraph) +loadScene file = do + result <- gameIO $ loadSceneGraphFromFile file + case result of + Left err -> gameError $ show err + Right g -> case validate g of + Nothing -> do + sceneRes <- resourceMap g + return (sceneRes, g) + Just err -> gameError err + +-- | Validate the given SceneGraph. +validate :: SceneGraph -> Maybe String +validate _ = Nothing + +-- | Load the scene described by the given 'SceneGraph'. +resourceMap :: SceneGraph -> Game s SceneResources +resourceMap g = execSubGame (resourceMap' g) emptySceneResources + +resourceMap' :: SceneGraph -> Loader () +resourceMap' node@(SceneLeaf nid props) = do + case nid of + "shader-program" -> newShaderProgram node + "model" -> newModel node + "light" -> newLight node + x -> return () + +resourceMap' node@(SceneNode nid props children) = do + mapM_ resourceMap' children + +-- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it. +loadResource :: String -- ^ Resource name. + -> (SceneResources -> Map String a) -- ^ Map getter. + -> (String -> a -> Loader ()) -- ^ Function to modify resources. + -> Loader a -- ^ Resource loader. + -> Loader a +loadResource key field modifyResources load = do + sceneData <- get + case M.lookup key $ field sceneData of + Just val -> return val + Nothing -> do + gameIO $ printf "Loading %s..." key + resource <- load + gameIO $ printf "done\n" + modifyResources key resource + return resource + +addShader name shader = modify $ \sceneData -> + sceneData { shaders = M.insert name shader $ shaders sceneData } + +addCustomProgram name prog = modify $ \sceneData -> + sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } + +addStaticProgram name prog = modify $ \sceneData -> + sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } + +addAnimatedProgram name prog = modify $ \sceneData -> + sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } + +addTexture name tex = modify $ \sceneData -> + sceneData { textures = M.insert name tex $ textures sceneData } + +addStaticModel name model = modify $ + \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData } + +addAnimatedModel name model = modify $ + \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData } + +-- Get the given resource from the data pool. +getResource :: (SceneResources -> Map String a) -> String -> Loader a +getResource field key = do + sceneData <- get + case M.lookup key $ field sceneData of + Just val -> return val + Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key + +---------------------- +-- Resource Loading -- +---------------------- + +newModel :: SceneGraph -> Loader () +newModel (SceneLeaf _ props) = do + name <- asString $ mandatory' "name" props + file <- asString $ mandatory' "file" props + tex <- asString $ mandatory' "texture" props + prog <- asString $ mandatory' "shader-program" props + ke <- asVec4 $ mandatory' "ke" props + ka <- asVec4 $ mandatory' "ka" props + kd <- asVec4 $ mandatory' "kd" props + ks <- asVec4 $ mandatory' "ks" props + shi <- asFloat $ mandatory' "shi" props + + let rotation = asRotation $ value "rotation" props + scale = asVec3 $ value "scale" props + + gameIO $ printf "Loading model %s..." name + model <- loadModel' file rotation scale + gameIO . putStrLn $ "done" + texture <- loadTexture tex + sceneRes <- get + + let material = Material ke ka kd ks shi + + case animated model of + False -> + case M.lookup prog $ staticPrograms sceneRes of + Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return () + Just p -> + let StaticProgram _ channels _ = p + in do + model' <- staticModelResource channels material texture model + loadResource name staticModels addStaticModel (return model') + return () + True -> + case M.lookup prog $ animatedPrograms sceneRes of + Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return () + Just p -> + let AnimatedProgram _ channels _ = p + in do + model' <- animatedModelResource channels material texture model + loadResource name animatedModels addAnimatedModel (return model') + return () + +loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model +loadModel' file rotation scale = do + let transform = + (case rotation of + Nothing -> Prelude.id + Just rot -> rotateModel rot) . + + (case scale of + Nothing -> Prelude.id + Just s -> flip Model.transformVerts $ + \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')) + + (fmap transform $ Model.loadModel file) >>= gameIO . toGround + +rotateModel :: Rotation -> Model -> Model +rotateModel (Rotation ax ay az order) model = + let mat = case order of + XYZ -> rotZ az * rotY ay * rotX ax + XZY -> rotY ay * rotZ az * rotX ax + YXZ -> rotZ az * rotX ax * rotY ay + YZX -> rotX ax * rotZ az * rotY ay + ZXY -> rotY ay * rotX ax * rotZ az + ZYX -> rotX ax * rotY ay * rotZ az + normalMat = fastNormalMatrix mat + + vTransform (Vec3 x' y' z') = + let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) + + nTransform (Vec3 x' y' z') = + let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) + in + flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model + +loadTexture :: FilePath -> Loader GL.Texture +loadTexture file = + loadResource file textures addTexture $ + GL.loadTextureImage file GL.gl_LINEAR GL.gl_LINEAR + +newShaderProgram :: SceneGraph -> Loader () +newShaderProgram (SceneLeaf _ props) = do + (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props + (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props + name <- asString $ mandatory' "name" props + stype <- asString $ mandatory' "type" props + prog <- GL.newProgram [vertShader, fragShader] + + let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name + + case stype of + "static" -> do + ambient <- asString $ mandatory' "ambient" props + diffuse <- asString $ mandatory' "diffuse" props + specular <- asString $ mandatory' "specular" props + shininess <- asString $ mandatory' "shininess" props + texture <- asString $ mandatory' "texture" props + modelview <- asString $ mandatory' "modelview" props + normalmat <- asString $ mandatory' "normalmat" props + projection <- asString $ mandatory' "projection" props + + ka <- getUniformLoc ambient + kd <- getUniformLoc diffuse + ks <- getUniformLoc specular + shi <- getUniformLoc shininess + tex <- getUniformLoc texture + mview <- getUniformLoc modelview + nmat <- getUniformLoc normalmat + proj <- getUniformLoc projection + + vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props + normChan <- fmap read $ asString $ mandatory' "normal-channel" props + texChan <- fmap read $ asString $ mandatory' "texture-channel" props + + let channels = StaticProgramChannels vertChan normChan texChan + uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj + + loadResource name staticPrograms addStaticProgram $ + return $ StaticProgram prog channels uniforms + return () + + "animated" -> do + ambient <- asString $ mandatory' "ambient" props + diffuse <- asString $ mandatory' "diffuse" props + specular <- asString $ mandatory' "specular" props + shininess <- asString $ mandatory' "shininess" props + texture <- asString $ mandatory' "texture" props + modelview <- asString $ mandatory' "modelview" props + normalmat <- asString $ mandatory' "normalmat" props + projection <- asString $ mandatory' "projection" props + + ka <- getUniformLoc ambient + kd <- getUniformLoc diffuse + ks <- getUniformLoc specular + shi <- getUniformLoc shininess + tex <- getUniformLoc texture + mview <- getUniformLoc modelview + nmat <- getUniformLoc normalmat + proj <- getUniformLoc projection + + vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props + vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props + normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props + normChan2 <- fmap read $ asString $ mandatory' "normal-channel2" props + texChan <- fmap read $ asString $ mandatory' "texture-channel" props + fp <- asString $ mandatory' "fp" props + p <- getUniformLoc fp + + let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan + uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj + + loadResource name animatedPrograms addAnimatedProgram $ + return $ AnimatedProgram prog channels uniforms + return () + + _ -> do + loadResource name customPrograms addCustomProgram $ return prog + return () + +loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) +loadShader _ [] = gameError $ "Loader::vertexShader: empty list" +loadShader shaderType ((stype, file):xs) = + if shaderType == GL.VertexShader && stype == "vertex-shader" || + shaderType == GL.FragmentShader && stype == "fragment-shader" + then let f = concat file + in loadShader' f shaderType >>= \shader -> return (f, shader) + else Spear.Scene.Loader.loadShader shaderType xs + +loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader +loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file + +newLight :: SceneGraph -> Loader () +newLight _ = return () + +-------------------- +-- Object Loading -- +-------------------- + +loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject +loadGO style sceneRes props transf = do + modelName <- asString . mandatory "model" $ props + axis <- asVec3 . mandatory "axis" $ props + let animSpeed = asFloat . value "animation-speed" $ props + go <- case getAnimatedModel sceneRes modelName of + Just model -> + return $ goNew style (Right model) [] transf axis + Nothing -> + case getStaticModel sceneRes modelName of + Just model -> + return $ goNew style (Left model) [] transf axis + Nothing -> + gameError $ "model " ++ modelName ++ " not found" + return $ case animSpeed of + Nothing -> go + Just s -> GO.setAnimationSpeed s go + +type CreateGameObject m a + = String -- ^ The object's name. + -> SceneResources + -> [Property] + -> Matrix3 -- ^ The object's transform. + -> m a + +-- | Load objects from the given 'SceneGraph'. +loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] +loadObjects newGO sceneRes g = + case node "layout" g of + Nothing -> return [] + Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n + +-- to-do: use a strict accumulator and make loadObjects tail recursive. +newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] +newObject newGO sceneRes (SceneNode nid props children) = + let o = newObject' newGO sceneRes nid props + in o : (concat $ fmap (newObject newGO sceneRes) children) + +newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] + +newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a +newObject' newGO sceneRes nid props = do + -- Optional properties. + let goType = (asString $ value "type" props) `unspecified` "unknown" + position = (asVec2 $ value "position" props) `unspecified` vec2 0 0 + rotation = (asVec2 $ value "rotation" props) `unspecified` vec2 0 0 + right' = (asVec2 $ value "right" props) `unspecified` vec2 1 0 + up' = asVec2 $ value "up" props + scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1 + + -- Compute the object's vectors if an up/forward vector has been specified. + let (right, up) = vectors up' + + newGO goType sceneRes props (M3.transform right up position) + +vectors :: Maybe Vector2 -> (Vector2, Vector2) +vectors up = case up of + Nothing -> (unitx2, unity2) + Just u -> (perp u, u) + +---------------------- +-- Helper functions -- +---------------------- + +-- Get the value of the given key. +value :: String -> [Property] -> Maybe [String] +value name props = case L.find ((==) name . fst) props of + Nothing -> Nothing + Just prop -> Just . snd $ prop + +unspecified :: Maybe a -> a -> a +unspecified (Just x) _ = x +unspecified Nothing x = x + +mandatory :: String -> [Property] -> Game s [String] +mandatory name props = case value name props of + Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name + Just x -> return x + +mandatory' :: String -> [Property] -> Loader [String] +mandatory' name props = mandatory name props + +asString :: Functor f => f [String] -> f String +asString = fmap concat + +asFloat :: Functor f => f [String] -> f Float +asFloat = fmap (read . concat) + +asVec2 :: Functor f => f [String] -> f Vector2 +asVec2 val = fmap toVec2 val + where toVec2 (x:y:_) = vec2 (read x) (read y) + toVec2 (x:[]) = let x' = read x in vec2 x' x' + +asVec3 :: Functor f => f [String] -> f Vector3 +asVec3 val = fmap toVec3 val + where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z) + toVec3 (x:[]) = let x' = read x in vec3 x' x' x' + +asVec4 :: Functor f => f [String] -> f Vector4 +asVec4 val = fmap toVec4 val + where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w) + toVec4 (x:[]) = let x' = read x in vec4 x' x' x' x' + +asRotation :: Functor f => f [String] -> f Rotation +asRotation val = fmap parseRotation val + where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order) + +data Rotation = Rotation + { ax :: Float + , ay :: Float + , az :: Float + , order :: RotationOrder + } + +data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq + +readOrder :: String -> RotationOrder +readOrder "xyz" = XYZ +readOrder "xzy" = XZY +readOrder "yxz" = YXZ +readOrder "yzx" = YZX +readOrder "zxy" = ZXY +readOrder "zyx" = ZYX diff --git a/Spear/Scene/SceneResources.hs b/Spear/Scene/SceneResources.hs index d75db56..3c7d204 100644 --- a/Spear/Scene/SceneResources.hs +++ b/Spear/Scene/SceneResources.hs @@ -1,72 +1,72 @@ -module Spear.Scene.SceneResources -( - -- * Data types - SceneResources(..) -, StaticProgram(..) -, AnimatedProgram(..) - -- * Construction -, emptySceneResources - -- * Accessors -, getShader -, getCustomProgram -, getStaticProgram -, getAnimatedProgram -, getTexture -, getStaticModel -, getAnimatedModel -) -where - -import Spear.Assets.Model as Model -import Spear.GL as GL -import Spear.Math.Vector -import Spear.Render.AnimatedModel -import Spear.Render.Material -import Spear.Render.Program -import Spear.Render.StaticModel -import Spear.Scene.Light - -import Data.Map as M - -data SceneResources = SceneResources - { shaders :: Map String GLSLShader - , customPrograms :: Map String GLSLProgram - , staticPrograms :: Map String StaticProgram - , animatedPrograms :: Map String AnimatedProgram - , textures :: Map String Texture - , staticModels :: Map String StaticModelResource - , animatedModels :: Map String AnimatedModelResource - , lights :: [Light] - } - --- | Build an empty instance of 'SceneResources'. -emptySceneResources = - SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty [] - --- | Get the shader specified by the given string. -getShader :: SceneResources -> String -> Maybe GLSLShader -getShader res key = M.lookup key $ shaders res - --- | Get the custom program specified by the given string. -getCustomProgram :: SceneResources -> String -> Maybe GLSLProgram -getCustomProgram res key = M.lookup key $ customPrograms res - --- | Get the static program specified by the given string. -getStaticProgram :: SceneResources -> String -> Maybe StaticProgram -getStaticProgram res key = M.lookup key $ staticPrograms res - --- | Get the animated program specified by the given string. -getAnimatedProgram :: SceneResources -> String -> Maybe AnimatedProgram -getAnimatedProgram res key = M.lookup key $ animatedPrograms res - --- | Get the texture specified by the given string. -getTexture :: SceneResources -> String -> Maybe Texture -getTexture res key = M.lookup key $ textures res - --- | Get the static model resource specified by the given string. -getStaticModel :: SceneResources -> String -> Maybe StaticModelResource -getStaticModel res key = M.lookup key $ staticModels res - --- | Get the animated model resource specified by the given string. -getAnimatedModel :: SceneResources -> String -> Maybe AnimatedModelResource -getAnimatedModel res key = M.lookup key $ animatedModels res +module Spear.Scene.SceneResources +( + -- * Data types + SceneResources(..) +, StaticProgram(..) +, AnimatedProgram(..) + -- * Construction +, emptySceneResources + -- * Accessors +, getShader +, getCustomProgram +, getStaticProgram +, getAnimatedProgram +, getTexture +, getStaticModel +, getAnimatedModel +) +where + +import Spear.Assets.Model as Model +import Spear.GL as GL +import Spear.Math.Vector +import Spear.Render.AnimatedModel +import Spear.Render.Material +import Spear.Render.Program +import Spear.Render.StaticModel +import Spear.Scene.Light + +import Data.Map as M + +data SceneResources = SceneResources + { shaders :: Map String GLSLShader + , customPrograms :: Map String GLSLProgram + , staticPrograms :: Map String StaticProgram + , animatedPrograms :: Map String AnimatedProgram + , textures :: Map String Texture + , staticModels :: Map String StaticModelResource + , animatedModels :: Map String AnimatedModelResource + , lights :: [Light] + } + +-- | Build an empty instance of 'SceneResources'. +emptySceneResources = + SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty [] + +-- | Get the shader specified by the given string. +getShader :: SceneResources -> String -> Maybe GLSLShader +getShader res key = M.lookup key $ shaders res + +-- | Get the custom program specified by the given string. +getCustomProgram :: SceneResources -> String -> Maybe GLSLProgram +getCustomProgram res key = M.lookup key $ customPrograms res + +-- | Get the static program specified by the given string. +getStaticProgram :: SceneResources -> String -> Maybe StaticProgram +getStaticProgram res key = M.lookup key $ staticPrograms res + +-- | Get the animated program specified by the given string. +getAnimatedProgram :: SceneResources -> String -> Maybe AnimatedProgram +getAnimatedProgram res key = M.lookup key $ animatedPrograms res + +-- | Get the texture specified by the given string. +getTexture :: SceneResources -> String -> Maybe Texture +getTexture res key = M.lookup key $ textures res + +-- | Get the static model resource specified by the given string. +getStaticModel :: SceneResources -> String -> Maybe StaticModelResource +getStaticModel res key = M.lookup key $ staticModels res + +-- | Get the animated model resource specified by the given string. +getAnimatedModel :: SceneResources -> String -> Maybe AnimatedModelResource +getAnimatedModel res key = M.lookup key $ animatedModels res diff --git a/Spear/Sys/Store.hs b/Spear/Sys/Store.hs index 3c1e720..9752707 100644 --- a/Spear/Sys/Store.hs +++ b/Spear/Sys/Store.hs @@ -1,195 +1,195 @@ -module Spear.Sys.Store -( - Store -, Index -, emptyStore -, store -, storel -, storeFree -, storeFreel -, element -, setElement -, withElement -) -where - - -import Data.List as L (find) -import Data.Maybe (isJust, isNothing) -import Data.Vector as V -import Control.Monad.State -- test -import Text.Printf -- test - - -type Index = Int - - -data Store a = Store - { objects :: Vector (Maybe a) -- ^ An array of objects. - , last :: Index -- ^ The greatest index assigned so far. - } - deriving Show - - -instance Functor Store where - fmap f (Store objects last) = Store (fmap (fmap f) objects) last - - --- | Create an empty store. -emptyStore :: Store a -emptyStore = Store V.empty (-1) - - --- | Store the given element in the store. -store :: a -> Store a -> (Index, Store a) -store elem s@(Store objects last) = - if last == V.length objects - 1 - then case findIndex isNothing objects of - Just i -> assign i elem s - Nothing -> store elem $ Store (objects V.++ V.replicate (max 1 last + 1) Nothing) last - else - assign (last+1) elem s - - --- Assign a slot the given element in the store. -assign :: Index -> a -> Store a -> (Index, Store a) -assign i elem (Store objects last) = - let objects' = objects // [(i,Just elem)] - in (i, Store objects' (max last i)) - - --- | Store the given elements in the store. -storel :: [a] -> Store a -> ([Index], Store a) -storel elems s@(Store objects last) = - let n = Prelude.length elems - (count, slots) = freeSlots objects - in - let -- place count elements in free slots. - (is, s'') = storeInSlots slots (Prelude.take count elems) s - - -- append the remaining elements - (is', s') = append (Prelude.drop count elems) s'' - in - (is Prelude.++ is', s') - - --- Count and return the free slots. -freeSlots :: Vector (Maybe a) -> (Int, Vector Int) -freeSlots v = let is = findIndices isNothing v in (V.length is, is) - - --- Store the given elements in the given slots. --- Pre: valid indices. -storeInSlots :: Vector Int -> [a] -> Store a -> ([Index], Store a) -storeInSlots is elems (Store objects last) = - let objects' = V.update_ objects is (V.fromList $ fmap Just elems) - last' = let i = V.length is - 1 - in if i < 0 then last else max last $ is ! i - in - (V.toList is, Store objects' last') - - --- Append the given elements to the last slot of the store, making space if necessary. -append :: [a] -> Store a -> ([Index], Store a) -append elems (Store objects last) = - let n = Prelude.length elems - indices = [last+1..last+n] - objects'' = if V.length objects <= last+n - then objects V.++ V.replicate n Nothing - else objects - objects' = objects'' // (Prelude.zipWith (,) indices (fmap Just elems)) - in - (indices, Store objects' $ last+n) - - --- | Free the given slot. -storeFree :: Index -> Store a -> Store a -storeFree i (Store objects last) = - let objects' = objects // [(i,Nothing)] - in if i == last - then case findLastIndex isJust objects' of - Just j -> Store objects' j - Nothing -> Store objects' 0 - else - Store objects' last - - -findLastIndex :: (a -> Bool) -> Vector a -> Maybe Index -findLastIndex p v = findLastIndex' p v Nothing 0 - where - findLastIndex' p v current i = - if i >= V.length v then current - else if p $ v V.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) - else findLastIndex' p v current (i+1) - - --- | Free the given slots. -storeFreel :: [Index] -> Store a -> Store a -storeFreel is (Store objects last) = - let objects' = objects // Prelude.zipWith (,) is (repeat Nothing) - last' = case L.find (==last) is of - Nothing -> last - Just _ -> case findLastIndex isJust objects' of - Just j -> j - Nothing -> (-1) - in - Store objects' last' - - --- | Access the element in the given slot. -element :: Index -> Store a -> Maybe a -element index (Store objects _) = objects V.! index - - --- | Set the element in the given slot. -setElement :: Index -> a -> Store a -> Store a -setElement index elem s = s { objects = objects s // [(index,Just elem)] } - - --- | Apply a function to the element in the given slot. -withElement :: Index -> Store a -> (a -> a) -> Store a -withElement index store f = store { objects = objects' } - where - objects' = objects store // [(index, obj')] - obj' = case element index store of - Nothing -> Nothing - Just x -> Just $ f x - - --- test -test :: IO () -test = evalStateT test' emptyStore - - -test' :: StateT (Store Int) IO () -test' = do - x <- store' 1 - y <- store' 2 - z <- store' 3 - w <- store' 4 - free y - store' 5 - free w - store' 6 - a <- store' 7 - free a - store' 8 - return () - - -store' :: Int -> StateT (Store Int) IO Int -store' elem = do - s <- get - let (i, s') = store elem s - put s' - lift $ printf "%d stored at %d; %s\n" elem i (show s') - return i - - -free :: Index -> StateT (Store Int) IO () -free i = do - s <- get - let s' = storeFree i s - put s' - lift $ printf "Slot %d freed; %s\n" i (show s') - +module Spear.Sys.Store +( + Store +, Index +, emptyStore +, store +, storel +, storeFree +, storeFreel +, element +, setElement +, withElement +) +where + + +import Data.List as L (find) +import Data.Maybe (isJust, isNothing) +import Data.Vector as V +import Control.Monad.State -- test +import Text.Printf -- test + + +type Index = Int + + +data Store a = Store + { objects :: Vector (Maybe a) -- ^ An array of objects. + , last :: Index -- ^ The greatest index assigned so far. + } + deriving Show + + +instance Functor Store where + fmap f (Store objects last) = Store (fmap (fmap f) objects) last + + +-- | Create an empty store. +emptyStore :: Store a +emptyStore = Store V.empty (-1) + + +-- | Store the given element in the store. +store :: a -> Store a -> (Index, Store a) +store elem s@(Store objects last) = + if last == V.length objects - 1 + then case findIndex isNothing objects of + Just i -> assign i elem s + Nothing -> store elem $ Store (objects V.++ V.replicate (max 1 last + 1) Nothing) last + else + assign (last+1) elem s + + +-- Assign a slot the given element in the store. +assign :: Index -> a -> Store a -> (Index, Store a) +assign i elem (Store objects last) = + let objects' = objects // [(i,Just elem)] + in (i, Store objects' (max last i)) + + +-- | Store the given elements in the store. +storel :: [a] -> Store a -> ([Index], Store a) +storel elems s@(Store objects last) = + let n = Prelude.length elems + (count, slots) = freeSlots objects + in + let -- place count elements in free slots. + (is, s'') = storeInSlots slots (Prelude.take count elems) s + + -- append the remaining elements + (is', s') = append (Prelude.drop count elems) s'' + in + (is Prelude.++ is', s') + + +-- Count and return the free slots. +freeSlots :: Vector (Maybe a) -> (Int, Vector Int) +freeSlots v = let is = findIndices isNothing v in (V.length is, is) + + +-- Store the given elements in the given slots. +-- Pre: valid indices. +storeInSlots :: Vector Int -> [a] -> Store a -> ([Index], Store a) +storeInSlots is elems (Store objects last) = + let objects' = V.update_ objects is (V.fromList $ fmap Just elems) + last' = let i = V.length is - 1 + in if i < 0 then last else max last $ is ! i + in + (V.toList is, Store objects' last') + + +-- Append the given elements to the last slot of the store, making space if necessary. +append :: [a] -> Store a -> ([Index], Store a) +append elems (Store objects last) = + let n = Prelude.length elems + indices = [last+1..last+n] + objects'' = if V.length objects <= last+n + then objects V.++ V.replicate n Nothing + else objects + objects' = objects'' // (Prelude.zipWith (,) indices (fmap Just elems)) + in + (indices, Store objects' $ last+n) + + +-- | Free the given slot. +storeFree :: Index -> Store a -> Store a +storeFree i (Store objects last) = + let objects' = objects // [(i,Nothing)] + in if i == last + then case findLastIndex isJust objects' of + Just j -> Store objects' j + Nothing -> Store objects' 0 + else + Store objects' last + + +findLastIndex :: (a -> Bool) -> Vector a -> Maybe Index +findLastIndex p v = findLastIndex' p v Nothing 0 + where + findLastIndex' p v current i = + if i >= V.length v then current + else if p $ v V.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) + else findLastIndex' p v current (i+1) + + +-- | Free the given slots. +storeFreel :: [Index] -> Store a -> Store a +storeFreel is (Store objects last) = + let objects' = objects // Prelude.zipWith (,) is (repeat Nothing) + last' = case L.find (==last) is of + Nothing -> last + Just _ -> case findLastIndex isJust objects' of + Just j -> j + Nothing -> (-1) + in + Store objects' last' + + +-- | Access the element in the given slot. +element :: Index -> Store a -> Maybe a +element index (Store objects _) = objects V.! index + + +-- | Set the element in the given slot. +setElement :: Index -> a -> Store a -> Store a +setElement index elem s = s { objects = objects s // [(index,Just elem)] } + + +-- | Apply a function to the element in the given slot. +withElement :: Index -> Store a -> (a -> a) -> Store a +withElement index store f = store { objects = objects' } + where + objects' = objects store // [(index, obj')] + obj' = case element index store of + Nothing -> Nothing + Just x -> Just $ f x + + +-- test +test :: IO () +test = evalStateT test' emptyStore + + +test' :: StateT (Store Int) IO () +test' = do + x <- store' 1 + y <- store' 2 + z <- store' 3 + w <- store' 4 + free y + store' 5 + free w + store' 6 + a <- store' 7 + free a + store' 8 + return () + + +store' :: Int -> StateT (Store Int) IO Int +store' elem = do + s <- get + let (i, s') = store elem s + put s' + lift $ printf "%d stored at %d; %s\n" elem i (show s') + return i + + +free :: Index -> StateT (Store Int) IO () +free i = do + s <- get + let s' = storeFree i s + put s' + lift $ printf "Slot %d freed; %s\n" i (show s') + 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 @@ -module Spear.Sys.Store.ID -( - ID -, IDStore -, emptyIDStore -, newID -, freeID -) -where - - -import Data.Vector.Unboxed as U -import Control.Monad.State -- test -import Text.Printf -- test - - -type ID = Int - - -data IDStore = IDStore - { assigned :: Vector Bool -- ^ A bit array indicating used IDs. - , last :: Int -- ^ The greatest ID assigned so far. - } - deriving Show - - --- | Create an empty ID store. -emptyIDStore :: IDStore -emptyIDStore = IDStore U.empty (-1) - - --- | Request an ID from the ID store. -newID :: IDStore -> (ID, IDStore) -newID store@(IDStore assigned last) = - if last == U.length assigned - 1 - then case findIndex (==False) assigned of - Just i -> assign i store - Nothing -> newID $ IDStore (assigned U.++ U.replicate (max 1 last + 1) False) last - else - assign (last+1) store - - --- Assign the given ID in the ID store. -assign :: ID -> IDStore -> (ID, IDStore) -assign i (IDStore assigned last) = - let assigned' = assigned // [(i,True)] - in (i, IDStore assigned' (max last i)) - - --- | Free the given ID from the ID store. -freeID :: ID -> IDStore -> IDStore -freeID i (IDStore assigned last) = - let assigned' = assigned // [(i,False)] - in if i == last - then case findLastIndex (==True) assigned' of - Just j -> IDStore assigned' j - Nothing -> IDStore assigned' 0 - else - IDStore assigned' last - - -findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int -findLastIndex p v = findLastIndex' p v Nothing 0 - where - findLastIndex' p v current i = - if i >= U.length v then current - else if p $ v U.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) - else findLastIndex' p v current (i+1) - - --- test -test :: IO () -test = evalStateT test' emptyIDStore - - -test' :: StateT IDStore IO () -test' = do - x <- request - y <- request - z <- request - w <- request - free y - request - free w - request - a <- request - free a - request - return () - - -request :: StateT IDStore IO ID -request = do - store <- get - let (i, store') = newID store - put store' - lift $ printf "ID requested, got %d; %s\n" i (show store') - return i - - -free :: ID -> StateT IDStore IO () -free i = do - store <- get - let store' = freeID i store - put store' - lift $ printf "ID %d freed; %s\n" i (show store') +module Spear.Sys.Store.ID +( + ID +, IDStore +, emptyIDStore +, newID +, freeID +) +where + + +import Data.Vector.Unboxed as U +import Control.Monad.State -- test +import Text.Printf -- test + + +type ID = Int + + +data IDStore = IDStore + { assigned :: Vector Bool -- ^ A bit array indicating used IDs. + , last :: Int -- ^ The greatest ID assigned so far. + } + deriving Show + + +-- | Create an empty ID store. +emptyIDStore :: IDStore +emptyIDStore = IDStore U.empty (-1) + + +-- | Request an ID from the ID store. +newID :: IDStore -> (ID, IDStore) +newID store@(IDStore assigned last) = + if last == U.length assigned - 1 + then case findIndex (==False) assigned of + Just i -> assign i store + Nothing -> newID $ IDStore (assigned U.++ U.replicate (max 1 last + 1) False) last + else + assign (last+1) store + + +-- Assign the given ID in the ID store. +assign :: ID -> IDStore -> (ID, IDStore) +assign i (IDStore assigned last) = + let assigned' = assigned // [(i,True)] + in (i, IDStore assigned' (max last i)) + + +-- | Free the given ID from the ID store. +freeID :: ID -> IDStore -> IDStore +freeID i (IDStore assigned last) = + let assigned' = assigned // [(i,False)] + in if i == last + then case findLastIndex (==True) assigned' of + Just j -> IDStore assigned' j + Nothing -> IDStore assigned' 0 + else + IDStore assigned' last + + +findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int +findLastIndex p v = findLastIndex' p v Nothing 0 + where + findLastIndex' p v current i = + if i >= U.length v then current + else if p $ v U.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) + else findLastIndex' p v current (i+1) + + +-- test +test :: IO () +test = evalStateT test' emptyIDStore + + +test' :: StateT IDStore IO () +test' = do + x <- request + y <- request + z <- request + w <- request + free y + request + free w + request + a <- request + free a + request + return () + + +request :: StateT IDStore IO ID +request = do + store <- get + let (i, store') = newID store + put store' + lift $ printf "ID requested, got %d; %s\n" i (show store') + return i + + +free :: ID -> StateT IDStore IO () +free i = do + store <- get + let store' = freeID i store + put store' + 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 @@ -{-# INCLUDE "Timer/Timer.h" #-} -{-# LINE 1 "Timer.hsc" #-} -{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} -{-# LINE 2 "Timer.hsc" #-} -module Spear.Sys.Timer -( - Timer -, initialiseTimingSubsystem -, newTimer -, tick -, reset -, stop -, start -, sleep -, getTime -, getDelta -, isRunning -) -where - - -import Foreign -import Foreign.C.Types -import Control.Monad -import System.IO.Unsafe - - - -{-# LINE 28 "Timer.hsc" #-} -type TimeReading = CDouble - -{-# LINE 30 "Timer.hsc" #-} - -data Timer = Timer { - getBaseTime :: TimeReading -, getPausedTime :: TimeReading -, getStopTime :: TimeReading -, getPrevTime :: TimeReading -, getCurTime :: TimeReading -, getDeltaTime :: CFloat -, getRunning :: CChar -} - - - -{-# LINE 43 "Timer.hsc" #-} - - -instance Storable Timer where - sizeOf _ = (48) -{-# LINE 47 "Timer.hsc" #-} - alignment _ = alignment (undefined :: TimeReading) - - peek ptr = do - baseTime <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr -{-# LINE 51 "Timer.hsc" #-} - pausedTime <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr -{-# LINE 52 "Timer.hsc" #-} - stopTime <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr -{-# LINE 53 "Timer.hsc" #-} - prevTime <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr -{-# LINE 54 "Timer.hsc" #-} - curTime <- (\hsc_ptr -> peekByteOff hsc_ptr 32) ptr -{-# LINE 55 "Timer.hsc" #-} - deltaTime <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr -{-# LINE 56 "Timer.hsc" #-} - stopped <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr -{-# LINE 57 "Timer.hsc" #-} - return $ Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped - - poke ptr (Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped) = do - (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr baseTime -{-# LINE 61 "Timer.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr pausedTime -{-# LINE 62 "Timer.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr stopTime -{-# LINE 63 "Timer.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr prevTime -{-# LINE 64 "Timer.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 32) ptr curTime -{-# LINE 65 "Timer.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 40) ptr deltaTime -{-# LINE 66 "Timer.hsc" #-} - (\hsc_ptr -> pokeByteOff hsc_ptr 44) ptr stopped -{-# LINE 67 "Timer.hsc" #-} - - -foreign import ccall "Timer.h timer_initialise_subsystem" - c_timer_initialise_subsystem :: IO () - -foreign import ccall "Timer.h timer_initialise_timer" - c_timer_initialise_timer :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_tick" - c_timer_tick :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_reset" - c_timer_reset :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_stop" - c_timer_stop :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_start" - c_timer_start :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_sleep" - c_timer_sleep :: CFloat -> IO () - -foreign import ccall "Timer.h timer_get_time" - c_timer_get_time :: Ptr Timer -> IO (CFloat) - -foreign import ccall "Timer.h timer_get_delta" - c_timer_get_delta :: Ptr Timer -> IO (CFloat) - -foreign import ccall "Timer.h timer_is_running" - c_timer_is_running :: Ptr Timer -> IO (CChar) - - --- | Initialises the timing subsystem. -initialiseTimingSubsystem :: IO () -initialiseTimingSubsystem = c_timer_initialise_subsystem - - --- | Creates a timer. -newTimer :: Timer -newTimer = unsafePerformIO . alloca $ \tptr -> do - c_timer_initialise_timer tptr - t <- peek tptr - return t - - --- | Updates the timer. -tick :: Timer -> IO (Timer) -tick t = alloca $ \tptr -> do - poke tptr t - c_timer_tick tptr - t' <- peek tptr - return t' - - --- | Resets the timer. -reset :: Timer -> IO (Timer) -reset t = alloca $ \tptr -> do - poke tptr t - c_timer_reset tptr - t' <- peek tptr - return t' - - --- | Stops the timer. -stop :: Timer -> IO (Timer) -stop t = alloca $ \tptr -> do - poke tptr t - c_timer_stop tptr - t' <- peek tptr - return t' - - --- | Starts the timer. -start :: Timer -> IO (Timer) -start t = alloca $ \tptr -> do - poke tptr t - c_timer_start tptr - t' <- peek tptr - return t' - - --- | Puts the caller thread to sleep for the given number of seconds. -sleep :: Float -> IO () -sleep = c_timer_sleep . realToFrac - - --- | Gets the timer's total running time. -getTime :: Timer -> Float -getTime t = unsafePerformIO . alloca $ \tptr -> do - poke tptr t - time <- c_timer_get_time tptr - return (realToFrac time) - - --- | Gets the timer's delta since the last tick. -getDelta :: Timer -> Float -getDelta t = unsafePerformIO . alloca $ \tptr -> do - poke tptr t - dt <- c_timer_get_delta tptr - return (realToFrac dt) - - --- | Returns true if the timer is running, false otherwise. -isRunning :: Timer -> Bool -isRunning t = unsafePerformIO . alloca $ \tptr -> do - poke tptr t - running <- c_timer_is_running tptr - 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 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} -module Spear.Sys.Timer -( - Timer -, initialiseTimingSubsystem -, newTimer -, tick -, reset -, stop -, start -, sleep -, getTime -, getDelta -, isRunning -) -where - - -import Foreign hiding (unsafePerformIO) -import Foreign.C.Types -import Control.Monad -import System.IO.Unsafe - - -#ifdef WIN32 -type TimeReading = CULLong -#else -type TimeReading = CDouble -#endif - -data Timer = Timer { - getBaseTime :: TimeReading -, getPausedTime :: TimeReading -, getStopTime :: TimeReading -, getPrevTime :: TimeReading -, getCurTime :: TimeReading -, getDeltaTime :: CFloat -, getRunning :: CChar -} - - -#include "Timer/Timer.h" - - -instance Storable Timer where - sizeOf _ = #{size timer} - alignment _ = alignment (undefined :: TimeReading) - - peek ptr = do - baseTime <- #{peek timer, baseTime} ptr - pausedTime <- #{peek timer, pausedTime} ptr - stopTime <- #{peek timer, stopTime} ptr - prevTime <- #{peek timer, prevTime} ptr - curTime <- #{peek timer, curTime} ptr - deltaTime <- #{peek timer, deltaTime} ptr - stopped <- #{peek timer, stopped} ptr - return $ Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped - - poke ptr (Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped) = do - #{poke timer, baseTime} ptr baseTime - #{poke timer, pausedTime} ptr pausedTime - #{poke timer, stopTime} ptr stopTime - #{poke timer, prevTime} ptr prevTime - #{poke timer, curTime} ptr curTime - #{poke timer, deltaTime} ptr deltaTime - #{poke timer, stopped} ptr stopped - - -foreign import ccall "Timer.h timer_initialise_subsystem" - c_timer_initialise_subsystem :: IO () - -foreign import ccall "Timer.h timer_initialise_timer" - c_timer_initialise_timer :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_tick" - c_timer_tick :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_reset" - c_timer_reset :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_stop" - c_timer_stop :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_start" - c_timer_start :: Ptr Timer -> IO () - -foreign import ccall "Timer.h timer_sleep" - c_timer_sleep :: CFloat -> IO () - -foreign import ccall "Timer.h timer_get_time" - c_timer_get_time :: Ptr Timer -> IO (CFloat) - -foreign import ccall "Timer.h timer_get_delta" - c_timer_get_delta :: Ptr Timer -> IO (CFloat) - -foreign import ccall "Timer.h timer_is_running" - c_timer_is_running :: Ptr Timer -> IO (CChar) - - --- | Initialises the timing subsystem. -initialiseTimingSubsystem :: IO () -initialiseTimingSubsystem = c_timer_initialise_subsystem - - --- | Creates a timer. -newTimer :: Timer -newTimer = unsafePerformIO . alloca $ \tptr -> do - c_timer_initialise_timer tptr - t <- peek tptr - return t - - --- | Updates the timer. -tick :: Timer -> IO (Timer) -tick t = alloca $ \tptr -> do - poke tptr t - c_timer_tick tptr - t' <- peek tptr - return t' - - --- | Resets the timer. -reset :: Timer -> IO (Timer) -reset t = alloca $ \tptr -> do - poke tptr t - c_timer_reset tptr - t' <- peek tptr - return t' - - --- | Stops the timer. -stop :: Timer -> IO (Timer) -stop t = alloca $ \tptr -> do - poke tptr t - c_timer_stop tptr - t' <- peek tptr - return t' - - --- | Starts the timer. -start :: Timer -> IO (Timer) -start t = alloca $ \tptr -> do - poke tptr t - c_timer_start tptr - t' <- peek tptr - return t' - - --- | Puts the caller thread to sleep for the given number of seconds. -sleep :: Float -> IO () -sleep = c_timer_sleep . realToFrac - - --- | Gets the timer's total running time. -getTime :: Timer -> Float -getTime t = unsafePerformIO . alloca $ \tptr -> do - poke tptr t - time <- c_timer_get_time tptr - return (realToFrac time) - - --- | Gets the timer's delta since the last tick. -getDelta :: Timer -> Float -getDelta t = unsafePerformIO . alloca $ \tptr -> do - poke tptr t - dt <- c_timer_get_delta tptr - return (realToFrac dt) - - --- | Returns true if the timer is running, false otherwise. -isRunning :: Timer -> Bool -isRunning t = unsafePerformIO . alloca $ \tptr -> do - poke tptr t - running <- c_timer_is_running tptr - return (running /= 0) +{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} +module Spear.Sys.Timer +( + Timer +, newTimer +, tick +, start +, stop +, reset +, getTime +, getDelta +, isRunning +, sleep +) +where + +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr +import Foreign.Storable +import Control.Monad +import System.IO.Unsafe + +#ifdef WIN32 +type TimeReading = CULLong +#else +type TimeReading = CDouble +#endif + +data Timer = Timer + { getBaseTime :: TimeReading + , getPausedTime :: TimeReading + , getStopTime :: TimeReading + , getPrevTime :: TimeReading + , getCurTime :: TimeReading + , getDeltaTime :: CFloat + , getRunning :: CChar + } + +#include "Timer/Timer.h" + +instance Storable Timer where + sizeOf _ = #{size Timer} + alignment _ = alignment (undefined :: TimeReading) + + peek ptr = do + baseTime <- #{peek Timer, baseTime} ptr + pausedTime <- #{peek Timer, pausedTime} ptr + stopTime <- #{peek Timer, stopTime} ptr + prevTime <- #{peek Timer, prevTime} ptr + curTime <- #{peek Timer, curTime} ptr + deltaTime <- #{peek Timer, deltaTime} ptr + stopped <- #{peek Timer, stopped} ptr + return $ Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped + + poke ptr (Timer baseTime pausedTime stopTime prevTime curTime deltaTime stopped) = do + #{poke Timer, baseTime} ptr baseTime + #{poke Timer, pausedTime} ptr pausedTime + #{poke Timer, stopTime} ptr stopTime + #{poke Timer, prevTime} ptr prevTime + #{poke Timer, curTime} ptr curTime + #{poke Timer, deltaTime} ptr deltaTime + #{poke Timer, stopped} ptr stopped + +foreign import ccall unsafe "Timer.h timer_init" + c_timer_init :: Ptr Timer -> IO () + +foreign import ccall unsafe "Timer.h timer_tick" + c_timer_tick :: Ptr Timer -> IO () + +foreign import ccall unsafe "Timer.h timer_start" + c_timer_start :: Ptr Timer -> IO () + +foreign import ccall unsafe "Timer.h timer_stop" + c_timer_stop :: Ptr Timer -> IO () + +foreign import ccall unsafe "Timer.h timer_reset" + c_timer_reset :: Ptr Timer -> IO () + +foreign import ccall unsafe "Timer.h timer_get_time" + c_timer_get_time :: Ptr Timer -> IO (CDouble) + +foreign import ccall unsafe "Timer.h timer_get_delta" + c_timer_get_delta :: Ptr Timer -> IO (CFloat) + +foreign import ccall unsafe "Timer.h timer_is_running" + c_timer_is_running :: Ptr Timer -> IO (CChar) + +foreign import ccall "Timer.h timer_sleep" + c_timer_sleep :: CFloat -> IO () + +-- | Construct a new timer. +newTimer :: Timer +newTimer = unsafePerformIO . unsafeInterleaveIO . alloca $ \tptr -> do + c_timer_init tptr + peek tptr + +-- | Update the timer. +tick :: Timer -> IO (Timer) +tick t = alloca $ \tptr -> do + poke tptr t + c_timer_tick tptr + peek tptr + +-- | Start the timer. +start :: Timer -> IO (Timer) +start t = alloca $ \tptr -> do + poke tptr t + c_timer_start tptr + t' <- peek tptr + return t' + +-- | Stop the timer. +stop :: Timer -> IO (Timer) +stop t = alloca $ \tptr -> do + poke tptr t + c_timer_stop tptr + peek tptr + +-- | Reset the timer. +reset :: Timer -> IO (Timer) +reset t = alloca $ \tptr -> do + poke tptr t + c_timer_reset tptr + peek tptr + +-- | Get the timer's total running time. +getTime :: Timer -> Double +getTime t = unsafeDupablePerformIO . alloca $ \tptr -> do + poke tptr t + time <- c_timer_get_time tptr + return (realToFrac time) + +-- | Get the time elapsed between the last two ticks. +getDelta :: Timer -> Float +getDelta t = unsafeDupablePerformIO . alloca $ \tptr -> do + poke tptr t + dt <- c_timer_get_delta tptr + return (realToFrac dt) + +-- | Return true if the timer is running (not stopped), false otherwise. +isRunning :: Timer -> Bool +isRunning t = unsafeDupablePerformIO . alloca $ \tptr -> do + poke tptr t + running <- c_timer_is_running tptr + return (running /= 0) + +-- | Put the caller thread to sleep for the given number of seconds. +sleep :: Float -> IO () +sleep = c_timer_sleep . realToFrac 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 @@ -#ifndef _SPEAR_TIMER_H -#define _SPEAR_TIMER_H +#pragma once +#ifdef WIN32 #ifdef _MSC_VER - #ifdef DLL_EXPORT - #define DECLDIR __declspec(dllexport) - #else - #define DECLDIR __declspec(dllimport) - #endif +typedef __int64 timeReading; #else - #define DECLDIR +typedef __UINT64_TYPE__ timeReading; #endif - -#ifdef WIN32 - #ifdef _MSC_VER - typedef __int64 timeReading; - #else - typedef __UINT64_TYPE__ timeReading; - #endif #else - typedef double timeReading; +typedef __UINT64_TYPE__ timeReading; #endif #ifdef __cplusplus -extern C { +extern "C" { #endif - + +/* + Header: Timer + A high resolution timer module. +*/ + +/* + Struct: Timer +*/ typedef struct -{ - timeReading baseTime; - timeReading pausedTime; - timeReading stopTime; - timeReading prevTime; - timeReading curTime; - float deltaTime; - char stopped; -} timer; +{ + timeReading baseTime; // The instant since we start timing. + timeReading stopTime; // The instant the timer is stopped. + timeReading prevTime; // The instant the timer was ticked prior to the last tick. + timeReading curTime; // The instant the timer was last ticked. + timeReading pausedTime; // Amount of time the timer has been stopped for. + float deltaTime; // Amount of time elapsed since the last call to tick. + char stopped; +} Timer; + +/* + Function: timer_init + Construct a new timer. + + The timer is initialised by making a call to reset(). Since time + calculations are measured from the instant the timer is reset (base time), + you probably want to make a manual call to reset() at the start of + your application, otherwise the application will be measuring times + from the instant the timer's constructor is called, which can be error prone. + + A call to start() must be made prior to any time calculations, as the + timer is initialised as stopped. +*/ +void timer_init (Timer*); -/// Initialises the timing subsystem. -void DECLDIR timer_initialise_subsystem (); +/* + Function: timer_tick + Update the timer's values. -/// Initialises a timer. -void DECLDIR timer_initialise_timer (timer* t); + This function updates the timer's running time and caches the time + elapsed since the last tick or since the start if this is the first + tick after the last call to start(). -/// Call every frame. -void DECLDIR timer_tick (timer* t); + This function has no effect on a stopped ticker. +*/ +void timer_tick (Timer*); -/// Call before message loop. -void DECLDIR timer_reset (timer* t); +/* + Function: timer_start + Start the timer. -/// Call when paused. -void DECLDIR timer_stop (timer* t); + This function starts the timer for the first time or resumes it + after a call to stop(). -/// Call when unpaused. -void DECLDIR timer_start (timer* t); + Note that this function does not reset the timer's base time; + it's only a mechanism to resume a stopped timer. +*/ +void timer_start (Timer*); -/// Puts the caller thread to sleep for the given number of seconds. -void DECLDIR timer_sleep (float seconds); +/* + Function: timer_stop + Stop the timer. -/// Returns total running time in seconds. -float DECLDIR timer_get_time (timer* t); + This function essentially freezes time; any values dependent on + the timer will behave as if time had not passed since the moment + the timer was stopped. -/// Returns the elapsed time in seconds. -float DECLDIR timer_get_delta (timer* t); + To resume the timer call start(). +*/ +void timer_stop (Timer*); -/// Gets the timer's running state. -char DECLDIR timer_is_running (timer* t); +/* + Function: timer_reset + Reset the timer. + + This function resets all of the timer's values such as running and + stop times and sets the timer to stopped. The total running time is + then measured from the instant the timer is reset, making the timer + behave as a newly constructed one. + + A call to start() must be made prior to any further time calculations. +*/ +void timer_reset (Timer*); + +/* + Function: timer_get_time + Get the total running time. + + The amount of time the timer has been stopped for is not taken + into account. +*/ +double timer_get_time (const Timer*); + +/* + Function: timer_get_delta + Get the time elapsed since the last tick, or since the start if + this is the first tick. +*/ +float timer_get_delta (const Timer*); + +/* + Function: timer_is_running + Return true if the timer is running (not stopped), false otherwise. +*/ +char timer_is_running (const Timer*); + +/* + Function: timer_sleep + Put the caller thread to sleep for the given number of seconds. +*/ +void timer_sleep (float seconds); #ifdef __cplusplus } #endif - -#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 @@ -#include "Timer.h" -#include - -#ifdef __APPLE__ - #include -#elif WIN32 - #define WIN32_LEAN_AND_MEAN - #include -#else // Linux - #include - const double NSEC_TO_SEC = 1.0f/1000000000.0f; - const double SEC_TO_NSEC = 1000000000.0f; -#endif - - -static double secondsPerCount; - - -void timer_initialise_subsystem () -{ -#ifdef WIN32 - __int64 countsPerSec; - QueryPerformanceFrequency((LARGE_INTEGER*)&countsPerSec); - secondsPerCount = 1.0 / (double)countsPerSec; -#else - /*struct timespec ts; - clock_getres(CLOCK_REALTIME, &ts); - secondsPerCount = (double)ts.tv_sec + ((double)ts.tv_nsec * NSEC_TO_SEC);*/ - secondsPerCount = 1.0f; -#endif -} - - -timeReading now () -{ - timeReading t; - -#ifdef __APPLE__ - t = mach_absolute_time(); -#elif WIN32 - QueryPerformanceCounter((LARGE_INTEGER*)&t); -#else - struct timespec ts; - clock_gettime(CLOCK_REALTIME, &ts); - t = ts.tv_sec + ((double)ts.tv_nsec * NSEC_TO_SEC); -#endif - - return t; -} - - -void DECLDIR timer_initialise_timer (timer* t) -{ - t->baseTime = 0; - t->pausedTime = 0; - t->stopTime = 0; - t->prevTime = 0; - t->curTime = 0; - t->deltaTime = 0; - t->stopped = 1; -} - - -void timer_tick (timer* t) -{ - if (t->stopped) - { - t->deltaTime = 0.0; - return; - } - - //Get the time on this frame. - t->curTime = now(); - - //Time delta between the current frame and the previous. - t->deltaTime = (float) ((t->curTime - t->prevTime) * secondsPerCount); - - //Update for next frame. - t->prevTime = t->curTime; - - // Force nonnegative. The DXSDK's CDXUTTimer mentions that if the - // processor goes into a power save mode or we get shuffled to - // another processor, then mDeltaTime can be negative. - if(t->deltaTime < 0.0) - { - t->deltaTime = 0.0; - } -} - - -void timer_reset (timer* t) -{ - t->curTime = now(); - t->baseTime = t->curTime; - t->prevTime = t->curTime; - t->stopTime = 0; - t->stopped = 0; -} - - -void timer_stop (timer* t) -{ - // Don't do anything if we are already stopped. - if (!t->stopped) - { - // Grab the stop time. - t->stopTime = now(); - - // Now we are stopped. - t->stopped = 1; - } -} - - -void timer_start (timer* t) -{ - // Only start if we are stopped. - if (t->stopped) - { - timeReading startTime = now(); - - // Accumulate the paused time. - t->pausedTime = t->pausedTime + startTime - t->stopTime; - - // Make the previous time valid. - t->prevTime = startTime; - - //Now we are running. - t->stopTime = 0; - t->stopped = 0; - } -} - - -void timer_sleep (float seconds) -{ -#ifdef WIN32 - Sleep((DWORD)(seconds * 1000)); -#else - struct timespec ts; - ts.tv_sec = 0; - ts.tv_nsec = seconds * SEC_TO_NSEC; - nanosleep(&ts, NULL); -#endif -} - - -float timer_get_time (timer* t) -{ - // If we are stopped, we do not count the time we have been stopped for. - if (t->stopped) - { - return (float)((t->stopTime - t->baseTime) * secondsPerCount); - } - // Otherwise return the time elapsed since the start of the game without counting the time we have been paused for. - else - { - return (float)((t->curTime - t->baseTime - t->pausedTime) * secondsPerCount); - } -} - - -float timer_get_delta (timer* t) -{ - return t->deltaTime; -} - - -char timer_is_running (timer* t) -{ - return !t->stopped; -} +#include "Timer.h" +#include + +#ifdef __APPLE__ + #include +#elif WIN32 + #define WIN32_LEAN_AND_MEAN + #include +#else // Linux + #include + const double NSEC_TO_SEC = 1.0 / 1000000000.0; + const double SEC_TO_NSECd = 1000000000.0; + const timeReading SEC_TO_NSEC = 1000000000; +#endif + +static double secondsPerCount; + +static void timer_initialise_subsystem () +{ +#ifdef WIN32 + __int64 countsPerSec; + QueryPerformanceFrequency((LARGE_INTEGER*)&countsPerSec); + secondsPerCount = 1.0 / (double)countsPerSec; +#else + struct timespec ts; + clock_getres(CLOCK_REALTIME, &ts); + secondsPerCount = (double)ts.tv_sec + ((double)ts.tv_nsec * NSEC_TO_SEC); +#endif +} + +static timeReading now () +{ + timeReading t; +#ifdef __APPLE__ + t = mach_absolute_time(); +#elif WIN32 + QueryPerformanceCounter((LARGE_INTEGER*)&t); +#else + struct timespec ts; + clock_gettime(CLOCK_REALTIME, &ts); + t = ts.tv_sec*SEC_TO_NSEC + ts.tv_nsec; +#endif + return t; +} + +void timer_init (Timer* timer) +{ + timer_initialise_subsystem(); + timer_reset (timer); +} + +void timer_tick (Timer* timer) +{ + if (timer->stopped) + { + timer->deltaTime = 0.0; + return; + } + + //Get the time on this frame. + timer->curTime = now(); + + //Time delta between the current frame and the previous. + timer->deltaTime = (float) ((timer->curTime - timer->prevTime) * secondsPerCount); + + //Update for next frame. + timer->prevTime = timer->curTime; + + // Force nonnegative. The DXSDK's CDXUTTimer mentions that if the + // processor goes into a power save mode or we get shuffled to + // another processor, then the delta time can be negative. + if(timer->deltaTime < 0.0f) + { + timer->deltaTime = 0.0f; + } +} + +void timer_reset (Timer* timer) +{ + timeReading n = now(); + timer->baseTime = n; + timer->stopTime = n; + timer->prevTime = n; + timer->curTime = n; + timer->pausedTime = 0; + timer->deltaTime = 0.0f; + timer->stopped = 1; +} + +void timer_stop (Timer* timer) +{ + // Don't do anything if we are already stopped. + if (!timer->stopped) + { + // Grab the stop time. + timer->stopTime = now(); + + // Now we are stopped. + timer->stopped = 1; + } +} + +void timer_start (Timer* timer) +{ + // Only start if we are stopped. + if (timer->stopped) + { + timeReading startTime = now(); + + // Accumulate the paused time. + timer->pausedTime = timer->pausedTime + startTime - timer->stopTime; + + // Make the previous time valid. + timer->prevTime = startTime; + + //Now we are running. + timer->stopTime = 0; + timer->stopped = 0; + } +} + +double timer_get_time (const Timer* timer) +{ + // If we are stopped, we do not count the time we have been stopped for. + if (timer->stopped) + { + return (double)((timer->stopTime - timer->baseTime) * secondsPerCount); + } + // Otherwise return the time elapsed since the start but without + // taking into account the time we have been stopped for. + else + { + return (double)((timer->curTime - timer->baseTime - timer->pausedTime) * secondsPerCount); + } +} + +float timer_get_delta (const Timer* timer) +{ + return timer->deltaTime; +} + +char timer_is_running (const Timer* timer) +{ + return !timer->stopped; +} + +void timer_sleep (float seconds) +{ +#ifdef WIN32 + Sleep((DWORD)(seconds * 1000)); +#else + struct timespec ts; + ts.tv_sec = (int) seconds; + ts.tv_nsec = (long) ((double)(seconds - (int)seconds) * SEC_TO_NSECd); + nanosleep(&ts, NULL); +#endif +} -- cgit v1.2.3