From 4700e77c897d6ced15f1aac6d3c9513ab0265d38 Mon Sep 17 00:00:00 2001
From: Jeanne-Kamikaze <jeannekamikaze@gmail.com>
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