From 4700e77c897d6ced15f1aac6d3c9513ab0265d38 Mon Sep 17 00:00:00 2001 From: Jeanne-Kamikaze Date: Sat, 27 Apr 2013 14:27:13 +0200 Subject: Updates --- Spear.cabal | 103 +++++++++++++----- Spear/App/Application.hs | 14 ++- Spear/App/Input.hs | 2 +- Spear/Collision.hs | 213 ------------------------------------ Spear/GL.hs | 2 +- Spear/Math/AABB.hs | 42 ++++--- Spear/Math/Circle.hs | 21 ++-- Spear/Math/Collision.hs | 242 +++++++++++++++++++++++++++++++++++++++++ Spear/Math/Frustum.hs | 28 +++++ Spear/Math/Octree.hs | 228 ++++++++++++++++++++++++++++++++++++++ Spear/Math/Physics.hs | 9 ++ Spear/Math/Physics/Rigid.hs | 125 +++++++++++++++++++++ Spear/Math/Physics/Types.hs | 11 ++ Spear/Math/Plane.hs | 21 ++-- Spear/Math/Quad.hs | 31 ------ Spear/Math/QuadTree.hs | 248 ------------------------------------------ Spear/Math/Sphere.hs | 26 +++++ Spear/Physics.hs | 10 -- Spear/Physics/Rigid.hs | 132 ---------------------- Spear/Physics/Types.hs | 13 --- Spear/Render/AnimatedModel.hs | 4 +- Spear/Render/StaticModel.hs | 4 +- Spear/Scene/GameObject.hs | 22 ++-- Spear/Scene/Loader.hs | 46 ++++---- Spear/Scene/Scene.hs | 150 ------------------------- 25 files changed, 840 insertions(+), 907 deletions(-) delete mode 100644 Spear/Collision.hs create mode 100644 Spear/Math/Collision.hs create mode 100644 Spear/Math/Frustum.hs create mode 100644 Spear/Math/Octree.hs create mode 100644 Spear/Math/Physics.hs create mode 100644 Spear/Math/Physics/Rigid.hs create mode 100644 Spear/Math/Physics/Types.hs delete mode 100644 Spear/Math/Quad.hs delete mode 100644 Spear/Math/QuadTree.hs create mode 100644 Spear/Math/Sphere.hs delete mode 100644 Spear/Physics.hs delete mode 100644 Spear/Physics/Rigid.hs delete mode 100644 Spear/Physics/Types.hs delete mode 100644 Spear/Scene/Scene.hs diff --git a/Spear.cabal b/Spear.cabal index 514bed9..e25b347 100644 --- a/Spear.cabal +++ b/Spear.cabal @@ -10,40 +10,86 @@ 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 -any, directory -any, - mtl -any, transformers -any, resourcet -any, parsec >= 3, - containers -any, vector -any, array -any - exposed-modules: Spear.Scene.GameObject Spear.Math.QuadTree - Spear.Physics.Types Spear.App Spear.App.Application Spear.App.Input - Spear.Assets.Image Spear.Assets.Model Spear.Collision - Spear.Math.AABB Spear.Math.Circle Spear.Math.Triangle Spear.Game - Spear.GL Spear.Math.Camera Spear.Math.Entity Spear.Math.Matrix3 - Spear.Math.Matrix4 Spear.Math.MatrixUtils Spear.Math.Plane - Spear.Math.Quaternion Spear.Math.Vector Spear.Math.Vector.Class - Spear.Math.Vector.Vector3 Spear.Math.Vector.Vector4 - Spear.Math.Vector.Vector2 - Spear.Physics Spear.Physics.Rigid Spear.Render.AnimatedModel - Spear.Render.Material Spear.Render.Model Spear.Render.Program - Spear.Render.StaticModel Spear.Scene.Graph Spear.Scene.Light - Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources - Spear.Sys.Timer Spear.Sys.Store Spear.Sys.Store.ID - Spear.Math.Quad Spear.Math.Ray - Spear.Math.Segment Spear.Math.Utils Spear.Math.Spatial2 + 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/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 - extra-libraries: stdc++ + 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 @@ -51,9 +97,12 @@ library 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: -rtsopts -fprof-auto -fprof-cafs - + + ghc-prof-options: -O2 -rtsopts -fprof-auto -fprof-cafs diff --git a/Spear/App/Application.hs b/Spear/App/Application.hs index 1a2a616..ce52f0d 100644 --- a/Spear/App/Application.hs +++ b/Spear/App/Application.hs @@ -1,6 +1,6 @@ module Spear.App.Application ( - -- * Data types + -- * Setup Dimensions , Context , SpearWindow @@ -9,7 +9,6 @@ module Spear.App.Application , DisplayBits(..) , WindowMode(..) , WindowSizeCallback - -- * Setup , setup , quit -- * Main loop @@ -18,6 +17,9 @@ module Spear.App.Application -- * Helpers , swapBuffers , getParam +, SpecialFeature(..) +, enableSpecial +, disableSpecial ) where @@ -54,17 +56,17 @@ setup (w, h) displayBits windowMode (major, minor) onResize' = 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 diff --git a/Spear/App/Input.hs b/Spear/App/Input.hs index 779557d..d49a3f7 100644 --- a/Spear/App/Input.hs +++ b/Spear/App/Input.hs @@ -34,7 +34,7 @@ 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 Data.StateVar +import Graphics.Rendering.OpenGL.GL.StateVar data Key = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H diff --git a/Spear/Collision.hs b/Spear/Collision.hs deleted file mode 100644 index 3b80696..0000000 --- a/Spear/Collision.hs +++ /dev/null @@ -1,213 +0,0 @@ -module Spear.Collision -( - -- * Collision tests - CollisionType(..) -, Collisionable(..) - -- * Collisioners -, Collisioner(..) - -- ** Construction -, aabbCollisioner -, circleCollisioner -, boxFromCircle -, buildAABB -, mkCols - -- ** Collision test -, collide - -- ** Manipulation -, move - -- * Helpers -, aabbFromCircle -) -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.Vector - - --- | Encodes several collision situations. -data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy - deriving (Eq, Show) - - -class Collisionable a where - collideBox :: AABB -> a -> CollisionType - collideCircle :: Circle -> a -> CollisionType - getAABB :: a -> AABB - getCircle :: a -> Circle - - -instance Collisionable AABB where - - collideBox box1@(AABB min1 max1) box2@(AABB min2 max2) - | (x max1) < (x min2) = NoCollision - | (x min1) > (x max2) = NoCollision - | (y max1) < (y min2) = NoCollision - | (y min1) > (y max2) = NoCollision - | box1 `aabbpt` min2 && box1 `aabbpt` max2 = FullyContains - | box2 `aabbpt` min1 && box2 `aabbpt` max1 = FullyContainedBy - | otherwise = Collision - - collideCircle circle@(Circle c r) aabb@(AABB min max) - | test == FullyContains || test == FullyContainedBy = test - | normSq (c - boxC) > (l + r)^2 = NoCollision - | otherwise = Collision - where - test = aabb `collideBox` aabbFromCircle circle - boxC = min + (max-min)/2 - l = norm $ min + (vec2 (x boxC) (y min)) - min - - getAABB = id - - getCircle = circleFromAABB - - -instance Collisionable Circle where - - collideBox 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 - - getAABB = aabbFromCircle - - getCircle = id - - -instance Collisionable Collisioner where - - collideBox box (AABBCol self) = collideBox box self - collideBox box (CircleCol self) = collideBox box self - - collideCircle circle (AABBCol self) = collideCircle circle self - collideCircle circle (CircleCol self) = collideCircle circle self - - getAABB (AABBCol box) = box - getAABB (CircleCol c) = aabbFromCircle c - - getCircle (AABBCol box) = circleFromAABB box - getCircle (CircleCol c) = c - - - - -aabbPoints :: AABB -> [Vector2] -aabbPoints (AABB 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 Collisioner - -- | An axis-aligned bounding box. - = AABBCol {-# UNPACK #-} !AABB - -- | A bounding circle. - | CircleCol {-# UNPACK #-} !Circle - - --- | Create a collisioner from the specified box. -aabbCollisioner :: AABB -> Collisioner -aabbCollisioner = AABBCol - - --- | Create a collisioner from the specified circle. -circleCollisioner :: Circle -> Collisioner -circleCollisioner = CircleCol - - --- | Create the minimal AABB collisioner fully containing the specified circle. -boxFromCircle :: Circle -> Collisioner -boxFromCircle = AABBCol . aabbFromCircle - - --- | Create the minimal AABB fully containing the specified collisioners. -buildAABB :: [Collisioner] -> AABB -buildAABB cols = aabb $ generatePoints cols - - -generatePoints :: [Collisioner] -> [Vector2] -generatePoints = foldr generate [] - where - generate (AABBCol (AABB pmin pmax)) acc = 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 (CircleCol (Circle c r)) acc = 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) - - --- | Compute AABB collisioners in view space from the given 3D AABB. -mkCols :: M4.Matrix4 -- ^ Modelview matrix - -> Box - -> [Collisioner] -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 = AABBCol $ AABB p1 p2 - col2 = AABBCol $ AABB p1 p3 - in - [col1, col2] - - --- | Collide the given collisioners. -collide :: Collisioner -> Collisioner -> CollisionType -collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2 -collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2 -collide (AABBCol box) (CircleCol circle) = collideBox box circle -collide (CircleCol circle) (AABBCol box) = collideCircle circle box - - --- | Move the collisioner. -move :: Vector2 -> Collisioner -> Collisioner -move v (AABBCol (AABB min max)) = AABBCol (AABB (min+v) (max+v)) -move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r) - - --- | Create the minimal box fully containing the specified circle. -aabbFromCircle :: Circle -> AABB -aabbFromCircle (Circle c r) = AABB bot top - where - bot = c - (vec2 r r) - top = c + (vec2 r r) - - --- | Create the minimal circle fully containing the specified box. -circleFromAABB :: AABB -> Circle -circleFromAABB (AABB min max) = Circle c r - where - c = scale 0.5 (min + max) - r = norm . scale 0.5 $ max - min diff --git a/Spear/GL.hs b/Spear/GL.hs index 814099f..b5b4dfb 100644 --- a/Spear/GL.hs +++ b/Spear/GL.hs @@ -166,7 +166,7 @@ newProgram shaders = do linkProgram program return program --- | Delete the program. +-- Delete the program. deleteProgram :: GLuint -> IO () --deleteProgram = glDeleteProgram deleteProgram prog = do diff --git a/Spear/Math/AABB.hs b/Spear/Math/AABB.hs index 0dacfa4..681f194 100644 --- a/Spear/Math/AABB.hs +++ b/Spear/Math/AABB.hs @@ -1,28 +1,40 @@ module Spear.Math.AABB ( - AABB(..) -, aabb -, aabbpt + AABB2(..) +, AABB3(..) +, aabb2 +, aabb3 +, aabb2pt +, aabb3pt ) where - import Spear.Math.Vector +import Data.List (foldl') --- | An axis-aligned bounding box. -data AABB = AABB {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 - +-- | An axis-aligned bounding box in 2D space. +data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 --- | Create a 'AABB' from the given points. -aabb :: [Vector2] -> AABB +-- | An axis-aligned bounding box in 3D space. +data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 -aabb [] = error "Attempting to build a BoundingVolume from an empty list!" +-- | 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) -aabb (x:xs) = foldr update (AABB x x) xs - where update p (AABB pmin pmax) = AABB (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. -aabbpt :: AABB -> Vector2 -> Bool -aabbpt (AABB 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/Circle.hs b/Spear/Math/Circle.hs index ab256a4..33b60ab 100644 --- a/Spear/Math/Circle.hs +++ b/Spear/Math/Circle.hs @@ -1,33 +1,26 @@ module Spear.Math.Circle -( - Circle(..) -, circle -, circlept -) where - import Spear.Math.Vector +import Data.List (foldl') --- | A bounding volume. +-- | A circle in 2D space. data Circle = Circle { center :: {-# UNPACK #-} !Vector2 , radius :: {-# UNPACK #-} !Float } - --- | Create a 'Sphere' from the given points. +-- | Create a circle from the given points. circle :: [Vector2] -> Circle -circle [] = error "Attempting to build a Circle from an empty list!" +circle [] = Circle zero2 0 circle (x:xs) = Circle c r where c = pmin + (pmax-pmin)/2 r = norm $ pmax - c - (pmin,pmax) = foldr update (x,x) xs - update p (pmin,pmax) = (min p pmin, max p pmax) - + (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. +-- | 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 new file mode 100644 index 0000000..47cc5fd --- /dev/null +++ b/Spear/Math/Collision.hs @@ -0,0 +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) + top = c + (vec3 r r r) \ No newline at end of file diff --git a/Spear/Math/Frustum.hs b/Spear/Math/Frustum.hs new file mode 100644 index 0000000..b23882a --- /dev/null +++ b/Spear/Math/Frustum.hs @@ -0,0 +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 diff --git a/Spear/Math/Octree.hs b/Spear/Math/Octree.hs new file mode 100644 index 0000000..f5538b4 --- /dev/null +++ b/Spear/Math/Octree.hs @@ -0,0 +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 diff --git a/Spear/Math/Physics.hs b/Spear/Math/Physics.hs new file mode 100644 index 0000000..f24139b --- /dev/null +++ b/Spear/Math/Physics.hs @@ -0,0 +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 diff --git a/Spear/Math/Physics/Rigid.hs b/Spear/Math/Physics/Rigid.hs new file mode 100644 index 0000000..198385e --- /dev/null +++ b/Spear/Math/Physics/Rigid.hs @@ -0,0 +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)-} diff --git a/Spear/Math/Physics/Types.hs b/Spear/Math/Physics/Types.hs new file mode 100644 index 0000000..73cd90e --- /dev/null +++ b/Spear/Math/Physics/Types.hs @@ -0,0 +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 diff --git a/Spear/Math/Plane.hs b/Spear/Math/Plane.hs index b20740c..08e4570 100644 --- a/Spear/Math/Plane.hs +++ b/Spear/Math/Plane.hs @@ -6,12 +6,9 @@ module Spear.Math.Plane ) where - import Spear.Math.Vector - -data PointPlanePos = Front | Back | Contained deriving (Eq, Ord, Show) - +data PointPlanePos = Front | Back | Contained deriving (Eq, Show) data Plane = Plane { n :: {-# UNPACK #-} !Vector3, @@ -19,13 +16,21 @@ data Plane = Plane } deriving(Eq, Show) - --- | Create a plane given a normal vector and a distance from the origin. +-- | Construct a plane from a normal vector and a distance from the origin. plane :: Vector3 -> Float -> Plane plane n d = Plane (normalise n) d - --- | Classify the given point's relative position with respect to the given plane. +-- | 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 diff --git a/Spear/Math/Quad.hs b/Spear/Math/Quad.hs deleted file mode 100644 index 6b6215c..0000000 --- a/Spear/Math/Quad.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Spear.Math.Quad -( - Quad(..) -, quadpt -) -where - - -import Spear.Math.Segment -import Spear.Math.Utils -import Spear.Math.Vector - - -data Quad = Quad - { tl :: {-# UNPACK #-} !Vector2 -- ^ Top left - , tr :: {-# UNPACK #-} !Vector2 -- ^ Top right - , br :: {-# UNPACK #-} !Vector2 -- ^ Bottom right - , bl :: {-# UNPACK #-} !Vector2 -- ^ Bottom left - } - - --- | Return 'True' if the given point is inside the given quad, 'False' otherwise. -quadpt :: Quad -> Vector2 -> Bool -quadpt (Quad tl tr br bl) p = - let - s1 = seglr (Segment tl tr) p - s2 = seglr (Segment tr br) p - s3 = seglr (Segment br bl) p - s4 = seglr (Segment bl tl) p - in - R == s1 && s1 == s2 && s2 == s3 && s3 == s4 diff --git a/Spear/Math/QuadTree.hs b/Spear/Math/QuadTree.hs deleted file mode 100644 index d6b6353..0000000 --- a/Spear/Math/QuadTree.hs +++ /dev/null @@ -1,248 +0,0 @@ -module Spear.Math.QuadTree -( - QuadTree -, makeQuadTree -, clone -, Spear.Math.QuadTree.insert -, Spear.Math.QuadTree.map -, gmap -) -where - -import Spear.Collision -import Spear.Math.AABB -import Spear.Math.Vector - -import Control.Applicative ((<*>)) -import Data.List -import Data.Functor -import Data.Monoid -import qualified Data.Foldable as F - - --- | Represents an QuadTree. -data QuadTree e - = QuadTree - { root :: !AABB - , ents :: ![e] - , c1 :: !(QuadTree e) - , c2 :: !(QuadTree e) - , c3 :: !(QuadTree e) - , c4 :: !(QuadTree e) - , c5 :: !(QuadTree e) - , c6 :: !(QuadTree e) - , c7 :: !(QuadTree e) - , c8 :: !(QuadTree e) - } - | - Leaf - { root :: !AABB - , ents :: ![e] - } - - --- | Builds an QuadTree using the specified AABB as the root and having the specified depth. -makeQuadTree :: Int -> AABB -> QuadTree e -makeQuadTree d root@(AABB min max) - | d == 0 = Leaf root [] - | otherwise = QuadTree root [] c1 c2 c3 c4 c5 c6 c7 c8 - where - boxes = subdivide root - c1 = makeQuadTree (d-1) $ boxes !! 0 - c2 = makeQuadTree (d-1) $ boxes !! 1 - c3 = makeQuadTree (d-1) $ boxes !! 2 - c4 = makeQuadTree (d-1) $ boxes !! 3 - c5 = makeQuadTree (d-1) $ boxes !! 4 - c6 = makeQuadTree (d-1) $ boxes !! 5 - c7 = makeQuadTree (d-1) $ boxes !! 6 - c8 = makeQuadTree (d-1) $ boxes !! 7 - - -subdivide :: AABB -> [AABB] -subdivide (AABB 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 = AABB min c - a2 = AABB ( vec2 (x min) (y min)) ( vec2 (x c) (y c) ) - a3 = AABB ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) - a4 = AABB ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) - a5 = AABB ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) - a6 = AABB ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) - a7 = AABB ( vec2 (x c) (y c) ) ( vec2 (x max) (y max)) - a8 = AABB c max - - --- | Clones the structure of an octree. The new octree has no entities. -clone :: QuadTree e -> QuadTree e -clone (Leaf root ents) = Leaf root [] -clone (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = QuadTree 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 -> AABB -> CollisionType) -> AABB -> e -> Bool -keep testAABB aabb e = test == FullyContainedBy - where test = e `testAABB` aabb - - --- | Inserts a list of entities into the given octree. -insert :: (e -> AABB -> CollisionType) -> QuadTree e -> [e] -> QuadTree e -insert testAABB octree es = octree' where (octree', _) = insert' testAABB es octree - - -insert' :: (e -> AABB -> CollisionType) -> [e] -> QuadTree e -> (QuadTree e, [e]) - -insert' testAABB es (Leaf root ents) = (Leaf root ents', outliers) - where - ents' = ents ++ ents_kept - ents_kept = filter (keep testAABB root) es - outliers = filter (not . keep testAABB root) es - -insert' testAABB es (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (QuadTree 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 testAABB root) new_ents - outliers = filter (not . keep testAABB root) new_ents - (c1', ents1) = insert' testAABB es c1 - (c2', ents2) = insert' testAABB es c2 - (c3', ents3) = insert' testAABB es c3 - (c4', ents4) = insert' testAABB es c4 - (c5', ents5) = insert' testAABB es c5 - (c6', ents6) = insert' testAABB es c6 - (c7', ents7) = insert' testAABB es c7 - (c8', ents8) = insert' testAABB es c8 - - --- | Extracts all entities from an octree. The resulting octree has no entities. -extract :: QuadTree e -> (QuadTree e, [e]) -extract (Leaf root ents) = (Leaf root [], ents) -extract (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (QuadTree 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 - - --- | Applies the given function to the entities in the octree. --- Entities that break out of their cell are reallocated appropriately. -map :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> QuadTree e -map testAABB f o = - let (o', outliers) = map' testAABB f o - in Spear.Math.QuadTree.insert testAABB o' outliers - - -map' :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> (QuadTree e, [e]) - - -map' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers) - where - ents' = fmap f ents - ents_kept = filter (keep testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - - -map' testAABB f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (QuadTree 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 testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - (c1', out1) = map' testAABB f c1 - (c2', out2) = map' testAABB f c2 - (c3', out3) = map' testAABB f c3 - (c4', out4) = map' testAABB f c4 - (c5', out5) = map' testAABB f c5 - (c6', out6) = map' testAABB f c6 - (c7', out7) = map' testAABB f c7 - (c8', out8) = map' testAABB f c8 - - --- | Applies a function to the entity groups in the octree. --- Entities that break out of their cell are reallocated appropriately. -gmap :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> QuadTree e -gmap testAABB f o = - let (o', outliers) = gmap' testAABB f o - in Spear.Math.QuadTree.insert testAABB o' outliers - - -gmap' :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> (QuadTree e, [e]) - -gmap' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers) - where - ents' = f <$> ents <*> ents - ents_kept = filter (keep testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - -gmap' testAABB f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (QuadTree 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 testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - (c1', out1) = gmap' testAABB f c1 - (c2', out2) = gmap' testAABB f c2 - (c3', out3) = gmap' testAABB f c3 - (c4', out4) = gmap' testAABB f c4 - (c5', out5) = gmap' testAABB f c5 - (c6', out6) = gmap' testAABB f c6 - (c7', out7) = gmap' testAABB f c7 - (c8', out8) = gmap' testAABB f c8 - - -population :: QuadTree e -> Int -population = F.foldr (\_ acc -> acc+1) 0 - - - - -instance Functor QuadTree where - - fmap f (Leaf root ents) = Leaf root $ fmap f ents - - fmap f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - QuadTree 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 QuadTree where - - foldMap f (Leaf root ents) = mconcat . fmap f $ ents - - foldMap f (QuadTree 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/Sphere.hs b/Spear/Math/Sphere.hs new file mode 100644 index 0000000..9c80811 --- /dev/null +++ b/Spear/Math/Sphere.hs @@ -0,0 +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) diff --git a/Spear/Physics.hs b/Spear/Physics.hs deleted file mode 100644 index c143e32..0000000 --- a/Spear/Physics.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Spear.Physics -( - module Spear.Physics.Rigid -, module Spear.Physics.Types -) -where - - -import Spear.Physics.Rigid -import Spear.Physics.Types diff --git a/Spear/Physics/Rigid.hs b/Spear/Physics/Rigid.hs deleted file mode 100644 index 99a9d5a..0000000 --- a/Spear/Physics/Rigid.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Spear.Physics.Rigid -( - module Spear.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 #-} !Vector2 - , velocity :: {-# UNPACK #-} !Vector2 - , acceleration :: {-# UNPACK #-} !Vector2 - } - - -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/Physics/Types.hs b/Spear/Physics/Types.hs deleted file mode 100644 index 62e0c04..0000000 --- a/Spear/Physics/Types.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Spear.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/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs index f8a5960..c2456b2 100644 --- a/Spear/Render/AnimatedModel.hs +++ b/Spear/Render/AnimatedModel.hs @@ -28,10 +28,10 @@ module Spear.Render.AnimatedModel where import Spear.Assets.Model -import Spear.Collision 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 @@ -219,7 +219,7 @@ mkColsFromAnimated -> Float -- ^ Frame progress -> Matrix4 -- ^ Modelview matrix -> AnimatedModelResource - -> [Collisioner] + -> [Collisioner2] mkColsFromAnimated f1 f2 fp modelview modelRes = let (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs index a57f8fd..2f74c06 100644 --- a/Spear/Render/StaticModel.hs +++ b/Spear/Render/StaticModel.hs @@ -18,10 +18,10 @@ module Spear.Render.StaticModel where import Spear.Assets.Model -import Spear.Collision 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 @@ -134,5 +134,5 @@ render uniforms (StaticModelRenderer model) = mkColsFromStatic :: Matrix4 -- ^ Modelview matrix -> StaticModelResource - -> [Collisioner] + -> [Collisioner2] mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) diff --git a/Spear/Scene/GameObject.hs b/Spear/Scene/GameObject.hs index 30211f4..5ea483b 100644 --- a/Spear/Scene/GameObject.hs +++ b/Spear/Scene/GameObject.hs @@ -8,8 +8,8 @@ module Spear.Scene.GameObject , goNew -- * Accessors , currentAnimation -, goAABB -, goAABBs +--, goAABB +--, goAABBs , collisioners , goRPGtransform , numCollisioners @@ -31,10 +31,10 @@ module Spear.Scene.GameObject where -import Spear.Collision as Col 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 @@ -73,7 +73,7 @@ dummyWindow = Window M4.id M4.id 0 0 640 480 data GameObject = GameObject { gameStyle :: !GameStyle , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) - , collisioners :: ![Collisioner] + , collisioners :: ![Collisioner2] , transform :: !M3.Matrix3 , axis :: !Vector3 , angle :: !Float @@ -170,7 +170,7 @@ instance S2.Spatial2 GameObject where -- | Create a new game object. goNew :: GameStyle -> Either StaticModelResource AM.AnimatedModelResource - -> [Collisioner] + -> [Collisioner2] -> M3.Matrix3 -- ^ Transform -> Vector3 -- ^ Axis of rotation -> GameObject @@ -194,13 +194,13 @@ goUpdate dt go = -- | Get the game object's ith bounding box. -goAABB :: Int -> GameObject -> AABB -goAABB i = getAABB . flip (!!) i . collisioners +--goAABB :: Int -> GameObject -> AABB2 +--goAABB i = getAABB . flip (!!) i . collisioners -- | Get the game object's bounding boxes. -goAABBs :: GameObject -> [AABB] -goAABBs = fmap getAABB . collisioners +--goAABBs :: GameObject -> [AABB2] +--goAABBs = fmap getAABB . collisioners -- | Get the game object's 3D transform. @@ -242,7 +242,7 @@ setAxis ax go = go { axis = ax } -- | Set the game object's collisioners. -setCollisioners :: [Collisioner] -> GameObject -> GameObject +setCollisioners :: [Collisioner2] -> GameObject -> GameObject setCollisioners cols go = go { collisioners = cols } @@ -252,7 +252,7 @@ setWindow wnd go = go { window = wnd } -- | Manipulate the game object's collisioners. -withCollisioners :: GameObject -> ([Collisioner] -> [Collisioner]) -> GameObject +withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject withCollisioners go f = go { collisioners = f $ collisioners go } diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs index 9d785fe..b61db94 100644 --- a/Spear/Scene/Loader.hs +++ b/Spear/Scene/Loader.hs @@ -18,9 +18,9 @@ module Spear.Scene.Loader where import Spear.Assets.Model as Model -import Spear.Collision 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) @@ -135,18 +135,18 @@ newModel (SceneLeaf _ props) = do 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 @@ -173,12 +173,12 @@ loadModel' file rotation scale = do (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 @@ -191,10 +191,10 @@ rotateModel (Rotation ax ay az order) model = 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 @@ -212,9 +212,9 @@ newShaderProgram (SceneLeaf _ props) = do 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 @@ -225,7 +225,7 @@ newShaderProgram (SceneLeaf _ props) = do modelview <- asString $ mandatory' "modelview" props normalmat <- asString $ mandatory' "normalmat" props projection <- asString $ mandatory' "projection" props - + ka <- getUniformLoc ambient kd <- getUniformLoc diffuse ks <- getUniformLoc specular @@ -234,18 +234,18 @@ newShaderProgram (SceneLeaf _ props) = do 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 @@ -255,7 +255,7 @@ newShaderProgram (SceneLeaf _ props) = do modelview <- asString $ mandatory' "modelview" props normalmat <- asString $ mandatory' "normalmat" props projection <- asString $ mandatory' "projection" props - + ka <- getUniformLoc ambient kd <- getUniformLoc diffuse ks <- getUniformLoc specular @@ -264,7 +264,7 @@ newShaderProgram (SceneLeaf _ props) = do 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 @@ -272,14 +272,14 @@ newShaderProgram (SceneLeaf _ props) = do 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 () @@ -352,10 +352,10 @@ newObject' newGO sceneRes nid props = do 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) diff --git a/Spear/Scene/Scene.hs b/Spear/Scene/Scene.hs deleted file mode 100644 index 57a9a40..0000000 --- a/Spear/Scene/Scene.hs +++ /dev/null @@ -1,150 +0,0 @@ -module Spear.Scene.Scene -( - -- * Data types - Scene - -- * Construction -, listScene - -- * Insertion and deletion -, add -, remove -, Spear.Scene.Scene.filter - -- * Queries -, find -, query - -- * Update and render -, update -, updateM -, Spear.Scene.Scene.collide -, collideM -, render -) -where - - -import Spear.Collision -import Spear.Game (Game) -import Spear.Math.AABB -import Spear.Math.QuadTree as QT - -import Control.Applicative ((<*>)) -import Control.Monad (foldM) -import Data.Foldable as F (foldl', mapM_) -import Data.Functor ((<$>)) -import qualified Data.List as L (delete, filter, find) - - -data Scene obj = - ListScene - { objects :: ![obj] - } - | - QuadTreeScene - { collideAABB :: obj -> AABB -> CollisionType - , world :: !(QuadTree obj) - } - - --- | Create a list-based scene. -listScene :: [obj] -> Scene obj -listScene = ListScene - - --- Create an octree-based scene. ---octreeScene :: (obj -> AABB -> CollisionType) -> (obj -> AABB) -> [obj] -> Scene obj msg ---octreeScene collide getAABB objs = OctreeScene [] collide $ makeOctree - - --- | Add a list of game objects to the given 'Scene'. -add :: Scene obj -> [obj] -> Scene obj -add (scene@ListScene {}) l = scene { objects = l ++ objects scene } -add (scene@QuadTreeScene {}) l = scene { world = QT.insert (collideAABB scene) (world scene) l } - - --- | Remove a game object from the given 'Scene'. -remove :: Eq obj => Scene obj -> obj -> Scene obj -remove (scene@ListScene {}) o = scene { objects = L.delete o (objects scene) } ---remove (scene@OctreeScene {}) o = - - --- | Remove those game objects that do not satisfy the given predicate from the 'Scene'. -filter :: (obj -> Bool) -> Scene obj -> Scene obj -filter pred (scene@ListScene {}) = scene { objects = L.filter pred (objects scene) } - - --- | Search for an object in the 'Scene'. -find :: (obj -> Bool) -> Scene obj -> Maybe obj -find pred (scene@ListScene {}) = L.find pred $ objects scene - - --- | Return all objects that satisfy the given predicate. -query :: (obj -> Bool) -> Scene obj -> [obj] -query pred (scene@ListScene {}) = L.filter pred $ objects scene - - -type Update obj = obj -> obj - - --- | Update the given scene. -update :: (obj -> obj) -> Scene obj -> Scene obj -update updt (scene@ListScene {}) = scene { objects = fmap updt $ objects scene } -update updt (scene@QuadTreeScene {}) = scene { world = QT.map (collideAABB scene) updt $ world scene } - - --- | Update the given scene. -updateM :: Monad m => (obj -> m obj) -> Scene obj -> m (Scene obj) -updateM updt scene@ListScene {} = mapM updt (objects scene) >>= return . ListScene - - -{-update' :: (obj -> (obj, [a])) -> Scene obj -> (Scene obj, [a]) - -update' updt (scene@ListScene {}) = - let (objs, msgs) = unzip . fmap updt $ objects scene - in (scene { objects = objs }, concat msgs)-} - - --- | Perform collisions. -collide :: ([obj] -> obj -> obj) -> Scene obj -> Scene obj - -collide col scene@ListScene {} = - let objs = objects scene - objs' = fmap (col objs) objs - in - scene { objects = objs' } - -collide col scene@QuadTreeScene {} = error "not yet implemented" - --scene { world = gmap (collideAABB scene) col $ world scene } - - --- | Perform collisions. -collideM :: Monad m => (obj -> obj -> m obj) -> Scene obj -> m (Scene obj) -collideM col scene@ListScene {} = - let objs = objects scene - - col' o = foldM f o objs - f o p = col o p - - objs' = sequence . fmap col' $ objs - in - objs' >>= return . ListScene - - -{-collide' :: (obj -> obj -> (obj, [a])) -> Scene obj -> (Scene obj, [a]) - -collide' col scene@ListScene {} = - let objs = objects scene - - --col' :: obj -> (obj, [a]) - col' o = foldl' f (o, []) objs - - --f :: (obj, [a]) -> obj -> (obj, [a]) - f (o, msgs) p = let (o', msgs') = col o p in (o', msgs' ++ msgs) - - (objs', msgs) = let (os, ms) = (unzip . fmap col' $ objs) in (os, concat ms) - in - (scene { objects = objs' }, msgs)-} - - --- | Render the given 'Scene'. -render :: (obj -> Game s ()) -> Scene obj -> Game s () -render rend (scene@ListScene {}) = Prelude.mapM_ rend $ objects scene -render rend (scene@QuadTreeScene {}) = F.mapM_ rend $ world scene -- cgit v1.2.3