aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Spear.cabal103
-rw-r--r--Spear/App/Application.hs14
-rw-r--r--Spear/App/Input.hs2
-rw-r--r--Spear/Collision.hs213
-rw-r--r--Spear/GL.hs2
-rw-r--r--Spear/Math/AABB.hs42
-rw-r--r--Spear/Math/Circle.hs21
-rw-r--r--Spear/Math/Collision.hs242
-rw-r--r--Spear/Math/Frustum.hs28
-rw-r--r--Spear/Math/Octree.hs228
-rw-r--r--Spear/Math/Physics.hs9
-rw-r--r--Spear/Math/Physics/Rigid.hs (renamed from Spear/Physics/Rigid.hs)49
-rw-r--r--Spear/Math/Physics/Types.hs (renamed from Spear/Physics/Types.hs)4
-rw-r--r--Spear/Math/Plane.hs21
-rw-r--r--Spear/Math/Quad.hs31
-rw-r--r--Spear/Math/QuadTree.hs248
-rw-r--r--Spear/Math/Sphere.hs26
-rw-r--r--Spear/Physics.hs10
-rw-r--r--Spear/Render/AnimatedModel.hs4
-rw-r--r--Spear/Render/StaticModel.hs4
-rw-r--r--Spear/Scene/GameObject.hs22
-rw-r--r--Spear/Scene/Loader.hs46
-rw-r--r--Spear/Scene/Scene.hs150
23 files changed, 726 insertions, 793 deletions
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.
10category: Game 10category: Game
11author: Marc Sunet 11author: Marc Sunet
12data-dir: "" 12data-dir: ""
13 13
14library 14library
15 build-depends: GLFW -any, OpenGL -any, OpenGLRaw -any, 15 build-depends: GLFW -any,
16 StateVar -any, base -any, bytestring -any, directory -any, 16 OpenGL -any,
17 mtl -any, transformers -any, resourcet -any, parsec >= 3, 17 OpenGLRaw -any,
18 containers -any, vector -any, array -any 18 StateVar -any,
19 exposed-modules: Spear.Scene.GameObject Spear.Math.QuadTree 19 base -any,
20 Spear.Physics.Types Spear.App Spear.App.Application Spear.App.Input 20 bytestring >= 0.10,
21 Spear.Assets.Image Spear.Assets.Model Spear.Collision 21 directory -any,
22 Spear.Math.AABB Spear.Math.Circle Spear.Math.Triangle Spear.Game 22 mtl -any,
23 Spear.GL Spear.Math.Camera Spear.Math.Entity Spear.Math.Matrix3 23 transformers -any,
24 Spear.Math.Matrix4 Spear.Math.MatrixUtils Spear.Math.Plane 24 resourcet -any,
25 Spear.Math.Quaternion Spear.Math.Vector Spear.Math.Vector.Class 25 parsec >= 3,
26 Spear.Math.Vector.Vector3 Spear.Math.Vector.Vector4 26 containers -any,
27 Spear.Math.Vector.Vector2 27 vector -any,
28 Spear.Physics Spear.Physics.Rigid Spear.Render.AnimatedModel 28 array -any
29 Spear.Render.Material Spear.Render.Model Spear.Render.Program 29
30 Spear.Render.StaticModel Spear.Scene.Graph Spear.Scene.Light 30 exposed-modules: Spear.App
31 Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources 31 Spear.App.Application
32 Spear.Sys.Timer Spear.Sys.Store Spear.Sys.Store.ID 32 Spear.App.Input
33 Spear.Math.Quad Spear.Math.Ray 33 Spear.Assets.Image
34 Spear.Math.Segment Spear.Math.Utils Spear.Math.Spatial2 34 Spear.Assets.Model
35 Spear.Game
36 Spear.GL
37 Spear.Math.AABB
38 Spear.Math.Camera
39 Spear.Math.Circle
40 Spear.Math.Collision
41 Spear.Math.Entity
42 Spear.Math.Frustum
43 Spear.Math.Matrix3
44 Spear.Math.Matrix4
45 Spear.Math.MatrixUtils
46 Spear.Math.Octree
47 Spear.Math.Plane
48 Spear.Math.Quaternion
49 Spear.Math.Ray
50 Spear.Math.Segment
51 Spear.Math.Spatial2
35 Spear.Math.Spatial3 52 Spear.Math.Spatial3
53 Spear.Math.Triangle
54 Spear.Math.Utils
55 Spear.Math.Vector
56 Spear.Math.Vector.Class
57 Spear.Math.Vector.Vector2
58 Spear.Math.Vector.Vector3
59 Spear.Math.Vector.Vector4
60 Spear.Render.AnimatedModel
61 Spear.Render.Material
62 Spear.Render.Model
63 Spear.Render.Program
64 Spear.Render.StaticModel
65 Spear.Scene.GameObject
66 Spear.Scene.Graph
67 Spear.Scene.Light
68 Spear.Scene.Loader
69 Spear.Scene.SceneResources
70 Spear.Sys.Store
71 Spear.Sys.Store.ID
72 Spear.Sys.Timer
73
36 exposed: True 74 exposed: True
75
37 buildable: True 76 buildable: True
77
38 build-tools: hsc2hs -any 78 build-tools: hsc2hs -any
79
39 cc-options: -O2 -g -Wno-unused-result 80 cc-options: -O2 -g -Wno-unused-result
81
40 c-sources: Spear/Assets/Image/Image.c 82 c-sources: Spear/Assets/Image/Image.c
41 Spear/Assets/Image/BMP/BMP_load.c Spear/Assets/Model/Model.c 83 Spear/Assets/Image/BMP/BMP_load.c
42 Spear/Assets/Model/MD2/MD2_load.c Spear/Assets/Model/OBJ/cvector.c 84 Spear/Assets/Model/Model.c
43 Spear/Assets/Model/OBJ/OBJ_load.c Spear/Render/RenderModel.c 85 Spear/Assets/Model/MD2/MD2_load.c
86 Spear/Assets/Model/OBJ/cvector.c
87 Spear/Assets/Model/OBJ/OBJ_load.c
88 Spear/Render/RenderModel.c
44 Spear/Sys/Timer/ctimer.c 89 Spear/Sys/Timer/ctimer.c
90
45 extensions: TypeFamilies 91 extensions: TypeFamilies
46 extra-libraries: stdc++ 92
47 includes: Spear/Assets/Image/BMP/BMP_load.h 93 includes: Spear/Assets/Image/BMP/BMP_load.h
48 Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h 94 Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h
49 Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h 95 Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h
@@ -51,9 +97,12 @@ library
51 Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h 97 Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h
52 Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h 98 Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h
53 Timer/Timer.h 99 Timer/Timer.h
100
54 include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render 101 include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render
55 Spear/Sys 102 Spear/Sys
103
56 hs-source-dirs: . 104 hs-source-dirs: .
105
57 ghc-options: -O2 106 ghc-options: -O2
58 ghc-prof-options: -rtsopts -fprof-auto -fprof-cafs 107
59 108 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 @@
1module Spear.App.Application 1module Spear.App.Application
2( 2(
3 -- * Data types 3 -- * Setup
4 Dimensions 4 Dimensions
5, Context 5, Context
6, SpearWindow 6, SpearWindow
@@ -9,7 +9,6 @@ module Spear.App.Application
9, DisplayBits(..) 9, DisplayBits(..)
10, WindowMode(..) 10, WindowMode(..)
11, WindowSizeCallback 11, WindowSizeCallback
12 -- * Setup
13, setup 12, setup
14, quit 13, quit
15 -- * Main loop 14 -- * Main loop
@@ -18,6 +17,9 @@ module Spear.App.Application
18 -- * Helpers 17 -- * Helpers
19, swapBuffers 18, swapBuffers
20, getParam 19, getParam
20, SpecialFeature(..)
21, enableSpecial
22, disableSpecial
21) 23)
22where 24where
23 25
@@ -54,17 +56,17 @@ setup (w, h) displayBits windowMode (major, minor) onResize' = do
54 openWindowHint OpenGLVersionMajor major 56 openWindowHint OpenGLVersionMajor major
55 openWindowHint OpenGLVersionMinor minor 57 openWindowHint OpenGLVersionMinor minor
56 disableSpecial AutoPollEvent 58 disableSpecial AutoPollEvent
57 59
58 let dimensions = GL.Size (unsafeCoerce w) (unsafeCoerce h) 60 let dimensions = GL.Size (unsafeCoerce w) (unsafeCoerce h)
59 result <- openWindow dimensions displayBits windowMode 61 result <- openWindow dimensions displayBits windowMode
60 windowTitle $= "Spear Game Framework" 62 windowTitle $= "Spear Game Framework"
61 GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) 63 GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h))
62 64
63 windowSizeCallback $= (onResize onResize') 65 windowSizeCallback $= (onResize onResize')
64 onResize' (Size (fromIntegral w) (fromIntegral h)) 66 onResize' (Size (fromIntegral w) (fromIntegral h))
65 67
66 initialiseTimingSubsystem 68 initialiseTimingSubsystem
67 69
68 rkey <- register quit 70 rkey <- register quit
69 return $ SpearWindow rkey 71 return $ SpearWindow rkey
70 72
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)
34import qualified Data.Vector.Unboxed as V 34import qualified Data.Vector.Unboxed as V
35import qualified Graphics.UI.GLFW as GLFW 35import qualified Graphics.UI.GLFW as GLFW
36import Graphics.Rendering.OpenGL.GL.CoordTrans 36import Graphics.Rendering.OpenGL.GL.CoordTrans
37import Data.StateVar 37import Graphics.Rendering.OpenGL.GL.StateVar
38 38
39data Key 39data Key
40 = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H 40 = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H
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 @@
1module Spear.Collision
2(
3 -- * Collision tests
4 CollisionType(..)
5, Collisionable(..)
6 -- * Collisioners
7, Collisioner(..)
8 -- ** Construction
9, aabbCollisioner
10, circleCollisioner
11, boxFromCircle
12, buildAABB
13, mkCols
14 -- ** Collision test
15, collide
16 -- ** Manipulation
17, move
18 -- * Helpers
19, aabbFromCircle
20)
21where
22
23
24import Spear.Assets.Model
25import Spear.Math.AABB
26import Spear.Math.Circle
27import qualified Spear.Math.Matrix4 as M4
28import Spear.Math.Plane
29import Spear.Math.Vector
30
31
32-- | Encodes several collision situations.
33data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy
34 deriving (Eq, Show)
35
36
37class Collisionable a where
38 collideBox :: AABB -> a -> CollisionType
39 collideCircle :: Circle -> a -> CollisionType
40 getAABB :: a -> AABB
41 getCircle :: a -> Circle
42
43
44instance Collisionable AABB where
45
46 collideBox box1@(AABB min1 max1) box2@(AABB min2 max2)
47 | (x max1) < (x min2) = NoCollision
48 | (x min1) > (x max2) = NoCollision
49 | (y max1) < (y min2) = NoCollision
50 | (y min1) > (y max2) = NoCollision
51 | box1 `aabbpt` min2 && box1 `aabbpt` max2 = FullyContains
52 | box2 `aabbpt` min1 && box2 `aabbpt` max1 = FullyContainedBy
53 | otherwise = Collision
54
55 collideCircle circle@(Circle c r) aabb@(AABB min max)
56 | test == FullyContains || test == FullyContainedBy = test
57 | normSq (c - boxC) > (l + r)^2 = NoCollision
58 | otherwise = Collision
59 where
60 test = aabb `collideBox` aabbFromCircle circle
61 boxC = min + (max-min)/2
62 l = norm $ min + (vec2 (x boxC) (y min)) - min
63
64 getAABB = id
65
66 getCircle = circleFromAABB
67
68
69instance Collisionable Circle where
70
71 collideBox box circle = case collideCircle circle box of
72 FullyContains -> FullyContainedBy
73 FullyContainedBy -> FullyContains
74 x -> x
75
76 collideCircle s1@(Circle c1 r1) s2@(Circle c2 r2)
77 | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy
78 | distance_centers <= sum_radii = Collision
79 | otherwise = NoCollision
80 where
81 distance_centers = normSq $ c1 - c2
82 sum_radii = (r1 + r2)^2
83 sub_radii = (r1 - r2)^2
84
85 getAABB = aabbFromCircle
86
87 getCircle = id
88
89
90instance Collisionable Collisioner where
91
92 collideBox box (AABBCol self) = collideBox box self
93 collideBox box (CircleCol self) = collideBox box self
94
95 collideCircle circle (AABBCol self) = collideCircle circle self
96 collideCircle circle (CircleCol self) = collideCircle circle self
97
98 getAABB (AABBCol box) = box
99 getAABB (CircleCol c) = aabbFromCircle c
100
101 getCircle (AABBCol box) = circleFromAABB box
102 getCircle (CircleCol c) = c
103
104
105
106
107aabbPoints :: AABB -> [Vector2]
108aabbPoints (AABB min max) = [p1,p2,p3,p4,p5,p6,p7,p8]
109 where
110 p1 = vec2 (x min) (y min)
111 p2 = vec2 (x min) (y min)
112 p3 = vec2 (x min) (y max)
113 p4 = vec2 (x min) (y max)
114 p5 = vec2 (x max) (y min)
115 p6 = vec2 (x max) (y min)
116 p7 = vec2 (x max) (y max)
117 p8 = vec2 (x max) (y max)
118
119
120-- | A collisioner component.
121data Collisioner
122 -- | An axis-aligned bounding box.
123 = AABBCol {-# UNPACK #-} !AABB
124 -- | A bounding circle.
125 | CircleCol {-# UNPACK #-} !Circle
126
127
128-- | Create a collisioner from the specified box.
129aabbCollisioner :: AABB -> Collisioner
130aabbCollisioner = AABBCol
131
132
133-- | Create a collisioner from the specified circle.
134circleCollisioner :: Circle -> Collisioner
135circleCollisioner = CircleCol
136
137
138-- | Create the minimal AABB collisioner fully containing the specified circle.
139boxFromCircle :: Circle -> Collisioner
140boxFromCircle = AABBCol . aabbFromCircle
141
142
143-- | Create the minimal AABB fully containing the specified collisioners.
144buildAABB :: [Collisioner] -> AABB
145buildAABB cols = aabb $ generatePoints cols
146
147
148generatePoints :: [Collisioner] -> [Vector2]
149generatePoints = foldr generate []
150 where
151 generate (AABBCol (AABB pmin pmax)) acc = p1:p2:p3:p4:p5:p6:p7:p8:acc
152 where
153 p1 = vec2 (x pmin) (y pmin)
154 p2 = vec2 (x pmin) (y pmin)
155 p3 = vec2 (x pmin) (y pmax)
156 p4 = vec2 (x pmin) (y pmax)
157 p5 = vec2 (x pmax) (y pmin)
158 p6 = vec2 (x pmax) (y pmin)
159 p7 = vec2 (x pmax) (y pmax)
160 p8 = vec2 (x pmax) (y pmax)
161
162 generate (CircleCol (Circle c r)) acc = p1:p2:p3:p4:acc
163 where
164 p1 = c + unitx2 * (vec2 r r)
165 p2 = c - unitx2 * (vec2 r r)
166 p3 = c + unity2 * (vec2 r r)
167 p4 = c - unity2 * (vec2 r r)
168
169
170-- | Compute AABB collisioners in view space from the given 3D AABB.
171mkCols :: M4.Matrix4 -- ^ Modelview matrix
172 -> Box
173 -> [Collisioner]
174mkCols modelview (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) =
175 let
176 toVec2 v = vec2 (x v) (y v)
177 p1 = toVec2 $ modelview `M4.mulp` vec3 xmin ymin zmax
178 p2 = toVec2 $ modelview `M4.mulp` vec3 xmax ymin zmin
179 p3 = toVec2 $ modelview `M4.mulp` vec3 xmax ymax zmin
180 col1 = AABBCol $ AABB p1 p2
181 col2 = AABBCol $ AABB p1 p3
182 in
183 [col1, col2]
184
185
186-- | Collide the given collisioners.
187collide :: Collisioner -> Collisioner -> CollisionType
188collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2
189collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2
190collide (AABBCol box) (CircleCol circle) = collideBox box circle
191collide (CircleCol circle) (AABBCol box) = collideCircle circle box
192
193
194-- | Move the collisioner.
195move :: Vector2 -> Collisioner -> Collisioner
196move v (AABBCol (AABB min max)) = AABBCol (AABB (min+v) (max+v))
197move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r)
198
199
200-- | Create the minimal box fully containing the specified circle.
201aabbFromCircle :: Circle -> AABB
202aabbFromCircle (Circle c r) = AABB bot top
203 where
204 bot = c - (vec2 r r)
205 top = c + (vec2 r r)
206
207
208-- | Create the minimal circle fully containing the specified box.
209circleFromAABB :: AABB -> Circle
210circleFromAABB (AABB min max) = Circle c r
211 where
212 c = scale 0.5 (min + max)
213 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
166 linkProgram program 166 linkProgram program
167 return program 167 return program
168 168
169-- | Delete the program. 169-- Delete the program.
170deleteProgram :: GLuint -> IO () 170deleteProgram :: GLuint -> IO ()
171--deleteProgram = glDeleteProgram 171--deleteProgram = glDeleteProgram
172deleteProgram prog = do 172deleteProgram prog = do
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 @@
1module Spear.Math.AABB 1module Spear.Math.AABB
2( 2(
3 AABB(..) 3 AABB2(..)
4, aabb 4, AABB3(..)
5, aabbpt 5, aabb2
6, aabb3
7, aabb2pt
8, aabb3pt
6) 9)
7where 10where
8 11
9
10import Spear.Math.Vector 12import Spear.Math.Vector
11 13
14import Data.List (foldl')
12 15
13-- | An axis-aligned bounding box. 16-- | An axis-aligned bounding box in 2D space.
14data AABB = AABB {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 17data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2
15
16 18
17-- | Create a 'AABB' from the given points. 19-- | An axis-aligned bounding box in 3D space.
18aabb :: [Vector2] -> AABB 20data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3
19 21
20aabb [] = error "Attempting to build a BoundingVolume from an empty list!" 22-- | Create a AABB from the given points.
23aabb2 :: [Vector2] -> AABB2
24aabb2 [] = AABB2 zero2 zero2
25aabb2 (x:xs) = foldl' update (AABB2 x x) xs
26 where update (AABB2 pmin pmax) p = AABB2 (min p pmin) (max p pmax)
21 27
22aabb (x:xs) = foldr update (AABB x x) xs 28-- | Create an AABB from the given points.
23 where update p (AABB pmin pmax) = AABB (min p pmin) (max p pmax) 29aabb3 :: [Vector3] -> AABB3
30aabb3 [] = AABB3 zero3 zero3
31aabb3 (x:xs) = foldl' update (AABB3 x x) xs
32 where update (AABB3 pmin pmax) p = AABB3 (min p pmin) (max p pmax)
24 33
34-- | Return 'True' if the given AABB contains the given point, 'False' otherwise.
35aabb2pt :: AABB2 -> Vector2 -> Bool
36aabb2pt (AABB2 pmin pmax) v = v >= pmin && v <= pmax
25 37
26-- | Return 'True' if the given 'AABB' contains the given point, 'False' otherwise. 38-- | Return 'True' if the given AABB contains the given point, 'False' otherwise.
27aabbpt :: AABB -> Vector2 -> Bool 39aabb3pt :: AABB3 -> Vector3 -> Bool
28aabbpt (AABB pmin pmax) v = v >= pmin && v <= pmax 40aabb3pt (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 @@
1module Spear.Math.Circle 1module Spear.Math.Circle
2(
3 Circle(..)
4, circle
5, circlept
6)
7where 2where
8 3
9
10import Spear.Math.Vector 4import Spear.Math.Vector
11 5
6import Data.List (foldl')
12 7
13-- | A bounding volume. 8-- | A circle in 2D space.
14data Circle = Circle 9data Circle = Circle
15 { center :: {-# UNPACK #-} !Vector2 10 { center :: {-# UNPACK #-} !Vector2
16 , radius :: {-# UNPACK #-} !Float 11 , radius :: {-# UNPACK #-} !Float
17 } 12 }
18 13
19 14-- | Create a circle from the given points.
20-- | Create a 'Sphere' from the given points.
21circle :: [Vector2] -> Circle 15circle :: [Vector2] -> Circle
22circle [] = error "Attempting to build a Circle from an empty list!" 16circle [] = Circle zero2 0
23circle (x:xs) = Circle c r 17circle (x:xs) = Circle c r
24 where 18 where
25 c = pmin + (pmax-pmin)/2 19 c = pmin + (pmax-pmin)/2
26 r = norm $ pmax - c 20 r = norm $ pmax - c
27 (pmin,pmax) = foldr update (x,x) xs 21 (pmin,pmax) = foldl' update (x,x) xs
28 update p (pmin,pmax) = (min p pmin, max p pmax) 22 update (pmin,pmax) p = (min p pmin, max p pmax)
29
30 23
31-- | Return 'True' if the given 'Sphere' contains the given point, 'False' otherwise. 24-- | Return 'True' if the given circle contains the given point, 'False' otherwise.
32circlept :: Circle -> Vector2 -> Bool 25circlept :: Circle -> Vector2 -> Bool
33circlept (Circle c r) p = r*r >= normSq (p - c) 26circlept (Circle c r) p = r*r >= normSq (p - c)
diff --git a/Spear/Math/Collision.hs b/Spear/Math/Collision.hs
new file mode 100644
index 0000000..47cc5fd
--- /dev/null
+++ b/Spear/Math/Collision.hs
@@ -0,0 +1,242 @@
1module Spear.Math.Collision
2(
3 CollisionType(..)
4 -- * 2D Collision
5, Collisionable2(..)
6, Collisioner2(..)
7 -- ** Construction
8, aabb2Collisioner
9, circleCollisioner
10, mkCols
11 -- ** Collision test
12, collide
13 -- ** Manipulation
14, move
15 -- ** Helpers
16, buildAABB2
17, aabb2FromCircle
18, circleFromAABB2
19 -- * 3D Collision
20, Collisionable3(..)
21 -- ** Helpers
22, aabb3FromSphere
23)
24where
25
26import Spear.Assets.Model
27import Spear.Math.AABB
28import Spear.Math.Circle
29import qualified Spear.Math.Matrix4 as M4
30import Spear.Math.Plane
31import Spear.Math.Sphere
32import Spear.Math.Vector
33
34import Data.List (foldl')
35
36data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy
37 deriving (Eq, Show)
38
39-- 2D collision
40
41class Collisionable2 a where
42
43 -- | Collide the object with an AABB.
44 collideAABB2 :: AABB2 -> a -> CollisionType
45
46 -- | Collide the object with a circle.
47 collideCircle :: Circle -> a -> CollisionType
48
49instance Collisionable2 AABB2 where
50
51 collideAABB2 box1@(AABB2 min1 max1) box2@(AABB2 min2 max2)
52 | (x max1) < (x min2) = NoCollision
53 | (x min1) > (x max2) = NoCollision
54 | (y max1) < (y min2) = NoCollision
55 | (y min1) > (y max2) = NoCollision
56 | box1 `aabb2pt` min2 && box1 `aabb2pt` max2 = FullyContains
57 | box2 `aabb2pt` min1 && box2 `aabb2pt` max1 = FullyContainedBy
58 | otherwise = Collision
59
60 collideCircle circle@(Circle c r) aabb@(AABB2 min max)
61 | test == FullyContains || test == FullyContainedBy = test
62 | normSq (c - boxC) > (l + r)^2 = NoCollision
63 | otherwise = Collision
64 where
65 test = collideAABB2 aabb $ aabb2FromCircle circle
66 boxC = min + (max-min)/2
67 l = norm $ min + (vec2 (x boxC) (y min)) - min
68
69instance Collisionable2 Circle where
70
71 collideAABB2 box circle = case collideCircle circle box of
72 FullyContains -> FullyContainedBy
73 FullyContainedBy -> FullyContains
74 x -> x
75
76 collideCircle s1@(Circle c1 r1) s2@(Circle c2 r2)
77 | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy
78 | distance_centers <= sum_radii = Collision
79 | otherwise = NoCollision
80 where
81 distance_centers = normSq $ c1 - c2
82 sum_radii = (r1 + r2)^2
83 sub_radii = (r1 - r2)^2
84
85instance Collisionable2 Collisioner2 where
86
87 collideAABB2 box (AABB2Col self) = collideAABB2 box self
88 collideAABB2 box (CircleCol self) = collideAABB2 box self
89
90 collideCircle circle (AABB2Col self) = collideCircle circle self
91 collideCircle circle (CircleCol self) = collideCircle circle self
92
93aabbPoints :: AABB2 -> [Vector2]
94aabbPoints (AABB2 min max) = [p1,p2,p3,p4,p5,p6,p7,p8]
95 where
96 p1 = vec2 (x min) (y min)
97 p2 = vec2 (x min) (y min)
98 p3 = vec2 (x min) (y max)
99 p4 = vec2 (x min) (y max)
100 p5 = vec2 (x max) (y min)
101 p6 = vec2 (x max) (y min)
102 p7 = vec2 (x max) (y max)
103 p8 = vec2 (x max) (y max)
104
105
106-- | A collisioner component.
107data Collisioner2
108 -- | An axis-aligned bounding box.
109 = AABB2Col {-# UNPACK #-} !AABB2
110 -- | A bounding circle.
111 | CircleCol {-# UNPACK #-} !Circle
112
113
114-- | Create a collisioner from the specified box.
115aabb2Collisioner :: AABB2 -> Collisioner2
116aabb2Collisioner = AABB2Col
117
118-- | Create a collisioner from the specified circle.
119circleCollisioner :: Circle -> Collisioner2
120circleCollisioner = CircleCol
121
122-- | Compute AABB collisioners in view space from the given AABB.
123mkCols :: M4.Matrix4 -- ^ Modelview matrix
124 -> Box
125 -> [Collisioner2]
126mkCols modelview (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) =
127 let
128 toVec2 v = vec2 (x v) (y v)
129 p1 = toVec2 $ modelview `M4.mulp` vec3 xmin ymin zmax
130 p2 = toVec2 $ modelview `M4.mulp` vec3 xmax ymin zmin
131 p3 = toVec2 $ modelview `M4.mulp` vec3 xmax ymax zmin
132 col1 = AABB2Col $ AABB2 p1 p2
133 col2 = AABB2Col $ AABB2 p1 p3
134 in
135 [col1, col2]
136
137-- | Create the minimal AABB fully containing the specified collisioners.
138buildAABB2 :: [Collisioner2] -> AABB2
139buildAABB2 cols = aabb2 $ generatePoints cols
140
141-- | Create the minimal box fully containing the specified circle.
142aabb2FromCircle :: Circle -> AABB2
143aabb2FromCircle (Circle c r) = AABB2 bot top
144 where
145 bot = c - (vec2 r r)
146 top = c + (vec2 r r)
147
148-- | Create the minimal circle fully containing the specified box.
149circleFromAABB2 :: AABB2 -> Circle
150circleFromAABB2 (AABB2 min max) = Circle c r
151 where
152 c = scale 0.5 (min + max)
153 r = norm . scale 0.5 $ max - min
154
155generatePoints :: [Collisioner2] -> [Vector2]
156generatePoints = foldl' generate []
157 where
158 generate acc (AABB2Col (AABB2 pmin pmax)) = p1:p2:p3:p4:p5:p6:p7:p8:acc
159 where
160 p1 = vec2 (x pmin) (y pmin)
161 p2 = vec2 (x pmin) (y pmin)
162 p3 = vec2 (x pmin) (y pmax)
163 p4 = vec2 (x pmin) (y pmax)
164 p5 = vec2 (x pmax) (y pmin)
165 p6 = vec2 (x pmax) (y pmin)
166 p7 = vec2 (x pmax) (y pmax)
167 p8 = vec2 (x pmax) (y pmax)
168
169 generate acc (CircleCol (Circle c r)) = p1:p2:p3:p4:acc
170 where
171 p1 = c + unitx2 * (vec2 r r)
172 p2 = c - unitx2 * (vec2 r r)
173 p3 = c + unity2 * (vec2 r r)
174 p4 = c - unity2 * (vec2 r r)
175
176-- | Collide the given collisioners.
177collide :: Collisioner2 -> Collisioner2 -> CollisionType
178collide (AABB2Col box1) (AABB2Col box2) = collideAABB2 box1 box2
179collide (AABB2Col box) (CircleCol circle) = collideAABB2 box circle
180collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2
181collide (CircleCol circle) (AABB2Col box) = collideCircle circle box
182
183-- | Move the collisioner.
184move :: Vector2 -> Collisioner2 -> Collisioner2
185move v (AABB2Col (AABB2 min max)) = AABB2Col (AABB2 (min+v) (max+v))
186move v (CircleCol (Circle c r)) = CircleCol (Circle (c+v) r)
187
188
189-- 3D collision
190
191class Collisionable3 a where
192
193 -- | Collide the object with an AABB.
194 collideAABB3 :: AABB3 -> a -> CollisionType
195
196 -- | Collide the object with a sphere.
197 collideSphere :: Sphere -> a -> CollisionType
198
199instance Collisionable3 AABB3 where
200
201 collideAABB3 box1@(AABB3 min1 max1) box2@(AABB3 min2 max2)
202 | (x max1) < (x min2) = NoCollision
203 | (x min1) > (x max2) = NoCollision
204 | (y max1) < (y min2) = NoCollision
205 | (y min1) > (y max2) = NoCollision
206 | box1 `aabb3pt` min2 && box1 `aabb3pt` max2 = FullyContains
207 | box2 `aabb3pt` min1 && box2 `aabb3pt` max1 = FullyContainedBy
208 | otherwise = Collision
209
210 collideSphere sphere@(Sphere c r) aabb@(AABB3 min max)
211 | test == FullyContains || test == FullyContainedBy = test
212 | normSq (c - boxC) > (l + r)^2 = NoCollision
213 | otherwise = Collision
214 where
215 test = collideAABB3 aabb $ aabb3FromSphere sphere
216 boxC = min + v
217 l = norm v
218 v = (max-min)/2
219
220instance Collisionable3 Sphere where
221
222 collideAABB3 box sphere = case collideSphere sphere box of
223 FullyContains -> FullyContainedBy
224 FullyContainedBy -> FullyContains
225 x -> x
226
227 collideSphere s1@(Sphere c1 r1) s2@(Sphere c2 r2)
228 | distance_centers <= sub_radii =
229 if (r1 > r2) then FullyContains else FullyContainedBy
230 | distance_centers <= sum_radii = Collision
231 | otherwise = NoCollision
232 where
233 distance_centers = normSq $ c1 - c2
234 sum_radii = (r1 + r2)^2
235 sub_radii = (r1 - r2)^2
236
237-- | Create the minimal box fully containing the specified sphere.
238aabb3FromSphere :: Sphere -> AABB3
239aabb3FromSphere (Sphere c r) = AABB3 bot top
240 where
241 bot = c - (vec3 r r r)
242 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 @@
1module Spear.Math.Frustum
2where
3
4import Spear.Math.Plane
5
6data Frustum = Frustum
7 { n :: {-# UNPACK #-} !Plane
8 , f :: {-# UNPACK #-} !Plane
9 , l :: {-# UNPACK #-} !Plane
10 , r :: {-# UNPACK #-} !Plane
11 , t :: {-# UNPACK #-} !Plane
12 , b :: {-# UNPACK #-} !Plane
13 } deriving Show
14
15-- | Construct a frustum.
16frustum
17 :: Plane -- ^ Near
18 -> Plane -- ^ Far
19 -> Plane -- ^ Left
20 -> Plane -- ^ Right
21 -> Plane -- ^ Top
22 -> Plane -- ^ Bottom
23 -> Frustum
24frustum = Frustum
25
26-- | Construct a frustum.
27fromList :: [Plane] -> Frustum
28fromList (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 @@
1module Spear.Math.Octree
2(
3 Octree
4, makeOctree
5, clone
6, Spear.Math.Octree.insert
7, Spear.Math.Octree.map
8, gmap
9)
10where
11
12import Spear.Math.AABB
13import Spear.Math.Collision
14import Spear.Math.Vector
15
16import Control.Applicative ((<*>))
17import Data.List
18import Data.Functor
19import Data.Monoid
20import qualified Data.Foldable as F
21
22-- | An octree.
23data Octree e
24 = Octree
25 { root :: !AABB2
26 , ents :: ![e]
27 , c1 :: !(Octree e)
28 , c2 :: !(Octree e)
29 , c3 :: !(Octree e)
30 , c4 :: !(Octree e)
31 , c5 :: !(Octree e)
32 , c6 :: !(Octree e)
33 , c7 :: !(Octree e)
34 , c8 :: !(Octree e)
35 }
36 |
37 Leaf
38 { root :: !AABB2
39 , ents :: ![e]
40 }
41
42-- | Construct an octree using the specified AABB as the root and having the specified depth.
43makeOctree :: Int -> AABB2 -> Octree e
44makeOctree d root@(AABB2 min max)
45 | d == 0 = Leaf root []
46 | otherwise = Octree root [] c1 c2 c3 c4 c5 c6 c7 c8
47 where
48 boxes = subdivide root
49 c1 = makeOctree (d-1) $ boxes !! 0
50 c2 = makeOctree (d-1) $ boxes !! 1
51 c3 = makeOctree (d-1) $ boxes !! 2
52 c4 = makeOctree (d-1) $ boxes !! 3
53 c5 = makeOctree (d-1) $ boxes !! 4
54 c6 = makeOctree (d-1) $ boxes !! 5
55 c7 = makeOctree (d-1) $ boxes !! 6
56 c8 = makeOctree (d-1) $ boxes !! 7
57
58subdivide :: AABB2 -> [AABB2]
59subdivide (AABB2 min max) = [a1, a2, a3, a4, a5, a6, a7, a8]
60 where
61 v = (max-min) / 2
62 c = vec2 (x min + x v) (y min + y v)
63 a1 = AABB2 min c
64 a2 = AABB2 ( vec2 (x min) (y min)) ( vec2 (x c) (y c) )
65 a3 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max))
66 a4 = AABB2 ( vec2 (x min) (y c) ) ( vec2 (x c) (y max))
67 a5 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) )
68 a6 = AABB2 ( vec2 (x c) (y min)) ( vec2 (x max) (y c) )
69 a7 = AABB2 ( vec2 (x c) (y c) ) ( vec2 (x max) (y max))
70 a8 = AABB2 c max
71
72-- | Clone the structure of the octree. The new octree has no entities.
73clone :: Octree e -> Octree e
74clone (Leaf root ents) = Leaf root []
75clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8'
76 where
77 c1' = clone c1
78 c2' = clone c2
79 c3' = clone c3
80 c4' = clone c4
81 c5' = clone c5
82 c6' = clone c6
83 c7' = clone c7
84 c8' = clone c8
85
86keep :: (e -> AABB2 -> CollisionType) -> AABB2 -> e -> Bool
87keep testAABB2 aabb e = test == FullyContainedBy
88 where test = e `testAABB2` aabb
89
90-- | Insert a list of entities into the octree.
91insert :: (e -> AABB2 -> CollisionType) -> Octree e -> [e] -> Octree e
92insert testAABB2 octree es = octree' where (octree', _) = insert' testAABB2 es octree
93
94insert' :: (e -> AABB2 -> CollisionType) -> [e] -> Octree e -> (Octree e, [e])
95
96insert' testAABB2 es (Leaf root ents) = (Leaf root ents', outliers)
97 where
98 ents' = ents ++ ents_kept
99 ents_kept = filter (keep testAABB2 root) es
100 outliers = filter (not . keep testAABB2 root) es
101
102insert' testAABB2 es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
103 (Octree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers)
104 where
105 ents' = ents ++ ents_kept
106 new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8
107 ents_kept = filter (keep testAABB2 root) new_ents
108 outliers = filter (not . keep testAABB2 root) new_ents
109 (c1', ents1) = insert' testAABB2 es c1
110 (c2', ents2) = insert' testAABB2 es c2
111 (c3', ents3) = insert' testAABB2 es c3
112 (c4', ents4) = insert' testAABB2 es c4
113 (c5', ents5) = insert' testAABB2 es c5
114 (c6', ents6) = insert' testAABB2 es c6
115 (c7', ents7) = insert' testAABB2 es c7
116 (c8', ents8) = insert' testAABB2 es c8
117
118-- | Extract all entities from the octree. The resulting octree has no entities.
119extract :: Octree e -> (Octree e, [e])
120extract (Leaf root ents) = (Leaf root [], ents)
121extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents')
122 where
123 (c1', ents1) = extract c1
124 (c2', ents2) = extract c2
125 (c3', ents3) = extract c3
126 (c4', ents4) = extract c4
127 (c5', ents5) = extract c5
128 (c6', ents6) = extract c6
129 (c7', ents7) = extract c7
130 (c8', ents8) = extract c8
131 ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8
132
133-- | Apply the given function to the entities in the octree.
134--
135-- Entities that break out of their cell are reallocated appropriately.
136map :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> Octree e
137map testAABB2 f o =
138 let (o', outliers) = map' testAABB2 f o
139 in Spear.Math.Octree.insert testAABB2 o' outliers
140
141map' :: (e -> AABB2 -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e])
142
143map' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers)
144 where
145 ents' = fmap f ents
146 ents_kept = filter (keep testAABB2 root) ents'
147 outliers = filter (not . keep testAABB2 root) ents'
148
149map' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
150 (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers)
151 where
152 ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8
153 ents_kept = filter (keep testAABB2 root) ents'
154 outliers = filter (not . keep testAABB2 root) ents'
155 (c1', out1) = map' testAABB2 f c1
156 (c2', out2) = map' testAABB2 f c2
157 (c3', out3) = map' testAABB2 f c3
158 (c4', out4) = map' testAABB2 f c4
159 (c5', out5) = map' testAABB2 f c5
160 (c6', out6) = map' testAABB2 f c6
161 (c7', out7) = map' testAABB2 f c7
162 (c8', out8) = map' testAABB2 f c8
163
164
165-- | Apply a function to the entity groups in the octree.
166--
167-- Entities that break out of their cell are reallocated appropriately.
168gmap :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e
169gmap testAABB2 f o =
170 let (o', outliers) = gmap' testAABB2 f o
171 in Spear.Math.Octree.insert testAABB2 o' outliers
172
173gmap' :: (e -> AABB2 -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e])
174
175gmap' testAABB2 f (Leaf root ents) = (Leaf root ents_kept, outliers)
176 where
177 ents' = f <$> ents <*> ents
178 ents_kept = filter (keep testAABB2 root) ents'
179 outliers = filter (not . keep testAABB2 root) ents'
180
181gmap' testAABB2 f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
182 (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers)
183 where
184 ents'= (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8
185 ents_kept = filter (keep testAABB2 root) ents'
186 outliers = filter (not . keep testAABB2 root) ents'
187 (c1', out1) = gmap' testAABB2 f c1
188 (c2', out2) = gmap' testAABB2 f c2
189 (c3', out3) = gmap' testAABB2 f c3
190 (c4', out4) = gmap' testAABB2 f c4
191 (c5', out5) = gmap' testAABB2 f c5
192 (c6', out6) = gmap' testAABB2 f c6
193 (c7', out7) = gmap' testAABB2 f c7
194 (c8', out8) = gmap' testAABB2 f c8
195
196instance Functor Octree where
197
198 fmap f (Leaf root ents) = Leaf root $ fmap f ents
199
200 fmap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
201 Octree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8'
202 where
203 c1' = fmap f c1
204 c2' = fmap f c2
205 c3' = fmap f c3
206 c4' = fmap f c4
207 c5' = fmap f c5
208 c6' = fmap f c6
209 c7' = fmap f c7
210 c8' = fmap f c8
211
212instance F.Foldable Octree where
213
214 foldMap f (Leaf root ents) = mconcat . fmap f $ ents
215
216 foldMap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
217 mconcat (fmap f ents) `mappend`
218 c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend`
219 c5' `mappend` c6' `mappend` c7' `mappend` c8'
220 where
221 c1' = F.foldMap f c1
222 c2' = F.foldMap f c2
223 c3' = F.foldMap f c3
224 c4' = F.foldMap f c4
225 c5' = F.foldMap f c5
226 c6' = F.foldMap f c6
227 c7' = F.foldMap f c7
228 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 @@
1module Spear.Math.Physics
2(
3 module Spear.Math.Physics.Rigid
4, module Spear.Math.Physics.Types
5)
6where
7
8import Spear.Math.Physics.Rigid
9import Spear.Math.Physics.Types
diff --git a/Spear/Physics/Rigid.hs b/Spear/Math/Physics/Rigid.hs
index 99a9d5a..198385e 100644
--- a/Spear/Physics/Rigid.hs
+++ b/Spear/Math/Physics/Rigid.hs
@@ -1,6 +1,6 @@
1module Spear.Physics.Rigid 1module Spear.Math.Physics.Rigid
2( 2(
3 module Spear.Physics.Types 3 module Spear.Math.Physics.Types
4, RigidBody(..) 4, RigidBody(..)
5, rigidBody 5, rigidBody
6, update 6, update
@@ -9,7 +9,6 @@ module Spear.Physics.Rigid
9) 9)
10where 10where
11 11
12
13import qualified Spear.Math.Matrix3 as M3 12import qualified Spear.Math.Matrix3 as M3
14import Spear.Math.Spatial2 13import Spear.Math.Spatial2
15import Spear.Math.Vector 14import Spear.Math.Vector
@@ -18,51 +17,47 @@ import Spear.Physics.Types
18import Data.List (foldl') 17import Data.List (foldl')
19import Control.Monad.State 18import Control.Monad.State
20 19
21
22data RigidBody = RigidBody 20data RigidBody = RigidBody
23 { mass :: {-# UNPACK #-} !Float 21 { mass :: {-# UNPACK #-} !Float
24 , position :: {-# UNPACK #-} !Vector2 22 , position :: {-# UNPACK #-} !Position
25 , velocity :: {-# UNPACK #-} !Vector2 23 , velocity :: {-# UNPACK #-} !Velocity
26 , acceleration :: {-# UNPACK #-} !Vector2 24 , acceleration :: {-# UNPACK #-} !Acceleration
27 } 25 }
28 26
29
30instance Spatial2 RigidBody where 27instance Spatial2 RigidBody where
31 28
32 move v body = body { position = v + position body } 29 move v body = body { position = v + position body }
33 30
34 moveFwd speed body = body { position = position body + scale speed unity2 } 31 moveFwd speed body = body { position = position body + scale speed unity2 }
35 32
36 moveBack speed body = body { position = position body + scale (-speed) unity2 } 33 moveBack speed body = body { position = position body + scale (-speed) unity2 }
37 34
38 strafeLeft speed body = body { position = position body + scale (-speed) unitx2 } 35 strafeLeft speed body = body { position = position body + scale (-speed) unitx2 }
39 36
40 strafeRight speed body = body { position = position body + scale speed unitx2 } 37 strafeRight speed body = body { position = position body + scale speed unitx2 }
41 38
42 rotate angle = id 39 rotate angle = id
43 40
44 setRotation angle = id 41 setRotation angle = id
45 42
46 pos = position 43 pos = position
47 44
48 fwd _ = unity2 45 fwd _ = unity2
49 46
50 up _ = unity2 47 up _ = unity2
51 48
52 right _ = unitx2 49 right _ = unitx2
53 50
54 transform body = M3.transform unitx2 unity2 $ position body 51 transform body = M3.transform unitx2 unity2 $ position body
55 52
56 setTransform transf body = body { position = M3.position transf } 53 setTransform transf body = body { position = M3.position transf }
57
58 setPos p body = body { position = p }
59 54
55 setPos p body = body { position = p }
60 56
61-- | Build a 'RigidBody'. 57-- | Build a 'RigidBody'.
62rigidBody :: Mass -> Position -> RigidBody 58rigidBody :: Mass -> Position -> RigidBody
63rigidBody m x = RigidBody m x zero2 zero2 59rigidBody m x = RigidBody m x zero2 zero2
64 60
65
66-- | Update the given 'RigidBody'. 61-- | Update the given 'RigidBody'.
67update :: [Force] -> Dt -> RigidBody -> RigidBody 62update :: [Force] -> Dt -> RigidBody -> RigidBody
68update forces dt body = 63update forces dt body =
@@ -78,19 +73,17 @@ update forces dt body =
78 in 73 in
79 RigidBody m r2 v2 a2 74 RigidBody m r2 v2 a2
80 75
81
82-- | Set the body's velocity. 76-- | Set the body's velocity.
83setVelocity :: Velocity -> RigidBody -> RigidBody 77setVelocity :: Velocity -> RigidBody -> RigidBody
84setVelocity v body = body { velocity = v } 78setVelocity v body = body { velocity = v }
85 79
86
87-- | Set the body's acceleration. 80-- | Set the body's acceleration.
88setAcceleration :: Acceleration -> RigidBody -> RigidBody 81setAcceleration :: Acceleration -> RigidBody -> RigidBody
89setAcceleration a body = body { acceleration = a } 82setAcceleration a body = body { acceleration = a }
90 83
91 84
92-- test 85-- test
93gravity = vec2 0 (-10) 86{-gravity = vec2 0 (-10)
94b0 = rigidBody 50 $ vec2 0 1000 87b0 = rigidBody 50 $ vec2 0 1000
95 88
96 89
@@ -129,4 +122,4 @@ show' body =
129 ", acceleration " ++ (showVec $ acceleration body) 122 ", acceleration " ++ (showVec $ acceleration body)
130 123
131 124
132showVec v = (show $ x v) ++ ", " ++ (show $ y v) 125showVec v = (show $ x v) ++ ", " ++ (show $ y v)-}
diff --git a/Spear/Physics/Types.hs b/Spear/Math/Physics/Types.hs
index 62e0c04..73cd90e 100644
--- a/Spear/Physics/Types.hs
+++ b/Spear/Math/Physics/Types.hs
@@ -1,10 +1,8 @@
1module Spear.Physics.Types 1module Spear.Math.Physics.Types
2where 2where
3 3
4
5import Spear.Math.Vector 4import Spear.Math.Vector
6 5
7
8type Dt = Float 6type Dt = Float
9type Force = Vector2 7type Force = Vector2
10type Mass = Float 8type Mass = Float
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
6) 6)
7where 7where
8 8
9
10import Spear.Math.Vector 9import Spear.Math.Vector
11 10
12 11data PointPlanePos = Front | Back | Contained deriving (Eq, Show)
13data PointPlanePos = Front | Back | Contained deriving (Eq, Ord, Show)
14
15 12
16data Plane = Plane 13data Plane = Plane
17 { n :: {-# UNPACK #-} !Vector3, 14 { n :: {-# UNPACK #-} !Vector3,
@@ -19,13 +16,21 @@ data Plane = Plane
19 } 16 }
20 deriving(Eq, Show) 17 deriving(Eq, Show)
21 18
22 19-- | Construct a plane from a normal vector and a distance from the origin.
23-- | Create a plane given a normal vector and a distance from the origin.
24plane :: Vector3 -> Float -> Plane 20plane :: Vector3 -> Float -> Plane
25plane n d = Plane (normalise n) d 21plane n d = Plane (normalise n) d
26 22
27 23-- | Construct a plane from three points.
28-- | Classify the given point's relative position with respect to the given plane. 24--
25-- Points must be given in counter-clockwise order.
26fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane
27fromPoints p0 p1 p2 = Plane n d
28 where n = normalise $ v1 `cross` v2
29 v1 = p2 - p1
30 v2 = p0 - p1
31 d = p0 `dot` n
32
33-- | Classify the given point's relative position with respect to the plane.
29classify :: Plane -> Vector3 -> PointPlanePos 34classify :: Plane -> Vector3 -> PointPlanePos
30classify (Plane n d) pt = 35classify (Plane n d) pt =
31 case (n `dot` pt - d) `compare` 0 of 36 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 @@
1module Spear.Math.Quad
2(
3 Quad(..)
4, quadpt
5)
6where
7
8
9import Spear.Math.Segment
10import Spear.Math.Utils
11import Spear.Math.Vector
12
13
14data Quad = Quad
15 { tl :: {-# UNPACK #-} !Vector2 -- ^ Top left
16 , tr :: {-# UNPACK #-} !Vector2 -- ^ Top right
17 , br :: {-# UNPACK #-} !Vector2 -- ^ Bottom right
18 , bl :: {-# UNPACK #-} !Vector2 -- ^ Bottom left
19 }
20
21
22-- | Return 'True' if the given point is inside the given quad, 'False' otherwise.
23quadpt :: Quad -> Vector2 -> Bool
24quadpt (Quad tl tr br bl) p =
25 let
26 s1 = seglr (Segment tl tr) p
27 s2 = seglr (Segment tr br) p
28 s3 = seglr (Segment br bl) p
29 s4 = seglr (Segment bl tl) p
30 in
31 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 @@
1module Spear.Math.QuadTree
2(
3 QuadTree
4, makeQuadTree
5, clone
6, Spear.Math.QuadTree.insert
7, Spear.Math.QuadTree.map
8, gmap
9)
10where
11
12import Spear.Collision
13import Spear.Math.AABB
14import Spear.Math.Vector
15
16import Control.Applicative ((<*>))
17import Data.List
18import Data.Functor
19import Data.Monoid
20import qualified Data.Foldable as F
21
22
23-- | Represents an QuadTree.
24data QuadTree e
25 = QuadTree
26 { root :: !AABB
27 , ents :: ![e]
28 , c1 :: !(QuadTree e)
29 , c2 :: !(QuadTree e)
30 , c3 :: !(QuadTree e)
31 , c4 :: !(QuadTree e)
32 , c5 :: !(QuadTree e)
33 , c6 :: !(QuadTree e)
34 , c7 :: !(QuadTree e)
35 , c8 :: !(QuadTree e)
36 }
37 |
38 Leaf
39 { root :: !AABB
40 , ents :: ![e]
41 }
42
43
44-- | Builds an QuadTree using the specified AABB as the root and having the specified depth.
45makeQuadTree :: Int -> AABB -> QuadTree e
46makeQuadTree d root@(AABB min max)
47 | d == 0 = Leaf root []
48 | otherwise = QuadTree root [] c1 c2 c3 c4 c5 c6 c7 c8
49 where
50 boxes = subdivide root
51 c1 = makeQuadTree (d-1) $ boxes !! 0
52 c2 = makeQuadTree (d-1) $ boxes !! 1
53 c3 = makeQuadTree (d-1) $ boxes !! 2
54 c4 = makeQuadTree (d-1) $ boxes !! 3
55 c5 = makeQuadTree (d-1) $ boxes !! 4
56 c6 = makeQuadTree (d-1) $ boxes !! 5
57 c7 = makeQuadTree (d-1) $ boxes !! 6
58 c8 = makeQuadTree (d-1) $ boxes !! 7
59
60
61subdivide :: AABB -> [AABB]
62subdivide (AABB min max) = [a1, a2, a3, a4, a5, a6, a7, a8]
63 where
64 v = (max-min) / 2
65 c = vec2 (x min + x v) (y min + y v)
66 a1 = AABB min c
67 a2 = AABB ( vec2 (x min) (y min)) ( vec2 (x c) (y c) )
68 a3 = AABB ( vec2 (x min) (y c) ) ( vec2 (x c) (y max))
69 a4 = AABB ( vec2 (x min) (y c) ) ( vec2 (x c) (y max))
70 a5 = AABB ( vec2 (x c) (y min)) ( vec2 (x max) (y c) )
71 a6 = AABB ( vec2 (x c) (y min)) ( vec2 (x max) (y c) )
72 a7 = AABB ( vec2 (x c) (y c) ) ( vec2 (x max) (y max))
73 a8 = AABB c max
74
75
76-- | Clones the structure of an octree. The new octree has no entities.
77clone :: QuadTree e -> QuadTree e
78clone (Leaf root ents) = Leaf root []
79clone (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = QuadTree root [] c1' c2' c3' c4' c5' c6' c7' c8'
80 where
81 c1' = clone c1
82 c2' = clone c2
83 c3' = clone c3
84 c4' = clone c4
85 c5' = clone c5
86 c6' = clone c6
87 c7' = clone c7
88 c8' = clone c8
89
90
91keep :: (e -> AABB -> CollisionType) -> AABB -> e -> Bool
92keep testAABB aabb e = test == FullyContainedBy
93 where test = e `testAABB` aabb
94
95
96-- | Inserts a list of entities into the given octree.
97insert :: (e -> AABB -> CollisionType) -> QuadTree e -> [e] -> QuadTree e
98insert testAABB octree es = octree' where (octree', _) = insert' testAABB es octree
99
100
101insert' :: (e -> AABB -> CollisionType) -> [e] -> QuadTree e -> (QuadTree e, [e])
102
103insert' testAABB es (Leaf root ents) = (Leaf root ents', outliers)
104 where
105 ents' = ents ++ ents_kept
106 ents_kept = filter (keep testAABB root) es
107 outliers = filter (not . keep testAABB root) es
108
109insert' testAABB es (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
110 (QuadTree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers)
111 where
112 ents' = ents ++ ents_kept
113 new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8
114 ents_kept = filter (keep testAABB root) new_ents
115 outliers = filter (not . keep testAABB root) new_ents
116 (c1', ents1) = insert' testAABB es c1
117 (c2', ents2) = insert' testAABB es c2
118 (c3', ents3) = insert' testAABB es c3
119 (c4', ents4) = insert' testAABB es c4
120 (c5', ents5) = insert' testAABB es c5
121 (c6', ents6) = insert' testAABB es c6
122 (c7', ents7) = insert' testAABB es c7
123 (c8', ents8) = insert' testAABB es c8
124
125
126-- | Extracts all entities from an octree. The resulting octree has no entities.
127extract :: QuadTree e -> (QuadTree e, [e])
128extract (Leaf root ents) = (Leaf root [], ents)
129extract (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (QuadTree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents')
130 where
131 (c1', ents1) = extract c1
132 (c2', ents2) = extract c2
133 (c3', ents3) = extract c3
134 (c4', ents4) = extract c4
135 (c5', ents5) = extract c5
136 (c6', ents6) = extract c6
137 (c7', ents7) = extract c7
138 (c8', ents8) = extract c8
139 ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8
140
141
142-- | Applies the given function to the entities in the octree.
143-- Entities that break out of their cell are reallocated appropriately.
144map :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> QuadTree e
145map testAABB f o =
146 let (o', outliers) = map' testAABB f o
147 in Spear.Math.QuadTree.insert testAABB o' outliers
148
149
150map' :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> (QuadTree e, [e])
151
152
153map' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers)
154 where
155 ents' = fmap f ents
156 ents_kept = filter (keep testAABB root) ents'
157 outliers = filter (not . keep testAABB root) ents'
158
159
160map' testAABB f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
161 (QuadTree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers)
162 where
163 ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8
164 ents_kept = filter (keep testAABB root) ents'
165 outliers = filter (not . keep testAABB root) ents'
166 (c1', out1) = map' testAABB f c1
167 (c2', out2) = map' testAABB f c2
168 (c3', out3) = map' testAABB f c3
169 (c4', out4) = map' testAABB f c4
170 (c5', out5) = map' testAABB f c5
171 (c6', out6) = map' testAABB f c6
172 (c7', out7) = map' testAABB f c7
173 (c8', out8) = map' testAABB f c8
174
175
176-- | Applies a function to the entity groups in the octree.
177-- Entities that break out of their cell are reallocated appropriately.
178gmap :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> QuadTree e
179gmap testAABB f o =
180 let (o', outliers) = gmap' testAABB f o
181 in Spear.Math.QuadTree.insert testAABB o' outliers
182
183
184gmap' :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> (QuadTree e, [e])
185
186gmap' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers)
187 where
188 ents' = f <$> ents <*> ents
189 ents_kept = filter (keep testAABB root) ents'
190 outliers = filter (not . keep testAABB root) ents'
191
192gmap' testAABB f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
193 (QuadTree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers)
194 where
195 ents' = (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8
196 ents_kept = filter (keep testAABB root) ents'
197 outliers = filter (not . keep testAABB root) ents'
198 (c1', out1) = gmap' testAABB f c1
199 (c2', out2) = gmap' testAABB f c2
200 (c3', out3) = gmap' testAABB f c3
201 (c4', out4) = gmap' testAABB f c4
202 (c5', out5) = gmap' testAABB f c5
203 (c6', out6) = gmap' testAABB f c6
204 (c7', out7) = gmap' testAABB f c7
205 (c8', out8) = gmap' testAABB f c8
206
207
208population :: QuadTree e -> Int
209population = F.foldr (\_ acc -> acc+1) 0
210
211
212
213
214instance Functor QuadTree where
215
216 fmap f (Leaf root ents) = Leaf root $ fmap f ents
217
218 fmap f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
219 QuadTree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8'
220 where
221 c1' = fmap f c1
222 c2' = fmap f c2
223 c3' = fmap f c3
224 c4' = fmap f c4
225 c5' = fmap f c5
226 c6' = fmap f c6
227 c7' = fmap f c7
228 c8' = fmap f c8
229
230
231
232instance F.Foldable QuadTree where
233
234 foldMap f (Leaf root ents) = mconcat . fmap f $ ents
235
236 foldMap f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
237 mconcat (fmap f ents) `mappend`
238 c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend`
239 c5' `mappend` c6' `mappend` c7' `mappend` c8'
240 where
241 c1' = F.foldMap f c1
242 c2' = F.foldMap f c2
243 c3' = F.foldMap f c3
244 c4' = F.foldMap f c4
245 c5' = F.foldMap f c5
246 c6' = F.foldMap f c6
247 c7' = F.foldMap f c7
248 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 @@
1module Spear.Math.Sphere
2where
3
4import Spear.Math.Vector
5
6import Data.List (foldl')
7
8-- | A sphere in 3D space.
9data Sphere = Sphere
10 { center :: {-# UNPACK #-} !Vector3
11 , radius :: {-# UNPACK #-} !Float
12 }
13
14-- | Create a sphere from the given points.
15sphere :: [Vector3] -> Sphere
16sphere [] = Sphere zero3 0
17sphere (x:xs) = Sphere c r
18 where
19 c = pmin + (pmax-pmin)/2
20 r = norm $ pmax - c
21 (pmin,pmax) = foldl' update (x,x) xs
22 update (pmin,pmax) p = (min p pmin, max p pmax)
23
24-- | Return 'True' if the given sphere contains the given point, 'False' otherwise.
25circlept :: Sphere -> Vector3 -> Bool
26circlept (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 @@
1module Spear.Physics
2(
3 module Spear.Physics.Rigid
4, module Spear.Physics.Types
5)
6where
7
8
9import Spear.Physics.Rigid
10import Spear.Physics.Types
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
28where 28where
29 29
30import Spear.Assets.Model 30import Spear.Assets.Model
31import Spear.Collision
32import Spear.Game 31import Spear.Game
33import Spear.GL 32import Spear.GL
34import Spear.Math.AABB 33import Spear.Math.AABB
34import Spear.Math.Collision
35import Spear.Math.Matrix4 (Matrix4) 35import Spear.Math.Matrix4 (Matrix4)
36import Spear.Math.Vector 36import Spear.Math.Vector
37import Spear.Render.Material 37import Spear.Render.Material
@@ -219,7 +219,7 @@ mkColsFromAnimated
219 -> Float -- ^ Frame progress 219 -> Float -- ^ Frame progress
220 -> Matrix4 -- ^ Modelview matrix 220 -> Matrix4 -- ^ Modelview matrix
221 -> AnimatedModelResource 221 -> AnimatedModelResource
222 -> [Collisioner] 222 -> [Collisioner2]
223mkColsFromAnimated f1 f2 fp modelview modelRes = 223mkColsFromAnimated f1 f2 fp modelview modelRes =
224 let 224 let
225 (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes 225 (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes
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
18where 18where
19 19
20import Spear.Assets.Model 20import Spear.Assets.Model
21import Spear.Collision
22import Spear.Game 21import Spear.Game
23import Spear.GL 22import Spear.GL
24import Spear.Math.AABB 23import Spear.Math.AABB
24import Spear.Math.Collision
25import Spear.Math.Matrix4 (Matrix4) 25import Spear.Math.Matrix4 (Matrix4)
26import Spear.Math.Vector 26import Spear.Math.Vector
27import Spear.Render.Material 27import Spear.Render.Material
@@ -134,5 +134,5 @@ render uniforms (StaticModelRenderer model) =
134mkColsFromStatic 134mkColsFromStatic
135 :: Matrix4 -- ^ Modelview matrix 135 :: Matrix4 -- ^ Modelview matrix
136 -> StaticModelResource 136 -> StaticModelResource
137 -> [Collisioner] 137 -> [Collisioner2]
138mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) 138mkColsFromStatic 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
8, goNew 8, goNew
9 -- * Accessors 9 -- * Accessors
10, currentAnimation 10, currentAnimation
11, goAABB 11--, goAABB
12, goAABBs 12--, goAABBs
13, collisioners 13, collisioners
14, goRPGtransform 14, goRPGtransform
15, numCollisioners 15, numCollisioners
@@ -31,10 +31,10 @@ module Spear.Scene.GameObject
31where 31where
32 32
33 33
34import Spear.Collision as Col
35import Spear.GL 34import Spear.GL
36import Spear.Math.AABB 35import Spear.Math.AABB
37import qualified Spear.Math.Camera as Cam 36import qualified Spear.Math.Camera as Cam
37import Spear.Math.Collision as Col
38import qualified Spear.Math.Matrix3 as M3 38import qualified Spear.Math.Matrix3 as M3
39import qualified Spear.Math.Matrix4 as M4 39import qualified Spear.Math.Matrix4 as M4
40import Spear.Math.MatrixUtils 40import Spear.Math.MatrixUtils
@@ -73,7 +73,7 @@ dummyWindow = Window M4.id M4.id 0 0 640 480
73data GameObject = GameObject 73data GameObject = GameObject
74 { gameStyle :: !GameStyle 74 { gameStyle :: !GameStyle
75 , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) 75 , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer)
76 , collisioners :: ![Collisioner] 76 , collisioners :: ![Collisioner2]
77 , transform :: !M3.Matrix3 77 , transform :: !M3.Matrix3
78 , axis :: !Vector3 78 , axis :: !Vector3
79 , angle :: !Float 79 , angle :: !Float
@@ -170,7 +170,7 @@ instance S2.Spatial2 GameObject where
170-- | Create a new game object. 170-- | Create a new game object.
171goNew :: GameStyle 171goNew :: GameStyle
172 -> Either StaticModelResource AM.AnimatedModelResource 172 -> Either StaticModelResource AM.AnimatedModelResource
173 -> [Collisioner] 173 -> [Collisioner2]
174 -> M3.Matrix3 -- ^ Transform 174 -> M3.Matrix3 -- ^ Transform
175 -> Vector3 -- ^ Axis of rotation 175 -> Vector3 -- ^ Axis of rotation
176 -> GameObject 176 -> GameObject
@@ -194,13 +194,13 @@ goUpdate dt go =
194 194
195 195
196-- | Get the game object's ith bounding box. 196-- | Get the game object's ith bounding box.
197goAABB :: Int -> GameObject -> AABB 197--goAABB :: Int -> GameObject -> AABB2
198goAABB i = getAABB . flip (!!) i . collisioners 198--goAABB i = getAABB . flip (!!) i . collisioners
199 199
200 200
201-- | Get the game object's bounding boxes. 201-- | Get the game object's bounding boxes.
202goAABBs :: GameObject -> [AABB] 202--goAABBs :: GameObject -> [AABB2]
203goAABBs = fmap getAABB . collisioners 203--goAABBs = fmap getAABB . collisioners
204 204
205 205
206-- | Get the game object's 3D transform. 206-- | Get the game object's 3D transform.
@@ -242,7 +242,7 @@ setAxis ax go = go { axis = ax }
242 242
243 243
244-- | Set the game object's collisioners. 244-- | Set the game object's collisioners.
245setCollisioners :: [Collisioner] -> GameObject -> GameObject 245setCollisioners :: [Collisioner2] -> GameObject -> GameObject
246setCollisioners cols go = go { collisioners = cols } 246setCollisioners cols go = go { collisioners = cols }
247 247
248 248
@@ -252,7 +252,7 @@ setWindow wnd go = go { window = wnd }
252 252
253 253
254-- | Manipulate the game object's collisioners. 254-- | Manipulate the game object's collisioners.
255withCollisioners :: GameObject -> ([Collisioner] -> [Collisioner]) -> GameObject 255withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject
256withCollisioners go f = go { collisioners = f $ collisioners go } 256withCollisioners go f = go { collisioners = f $ collisioners go }
257 257
258 258
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
18where 18where
19 19
20import Spear.Assets.Model as Model 20import Spear.Assets.Model as Model
21import Spear.Collision
22import Spear.Game 21import Spear.Game
23import qualified Spear.GL as GL 22import qualified Spear.GL as GL
23import Spear.Math.Collision
24import Spear.Math.Matrix3 as M3 24import Spear.Math.Matrix3 as M3
25import Spear.Math.Matrix4 as M4 25import Spear.Math.Matrix4 as M4
26import Spear.Math.MatrixUtils (fastNormalMatrix) 26import Spear.Math.MatrixUtils (fastNormalMatrix)
@@ -135,18 +135,18 @@ newModel (SceneLeaf _ props) = do
135 kd <- asVec4 $ mandatory' "kd" props 135 kd <- asVec4 $ mandatory' "kd" props
136 ks <- asVec4 $ mandatory' "ks" props 136 ks <- asVec4 $ mandatory' "ks" props
137 shi <- asFloat $ mandatory' "shi" props 137 shi <- asFloat $ mandatory' "shi" props
138 138
139 let rotation = asRotation $ value "rotation" props 139 let rotation = asRotation $ value "rotation" props
140 scale = asVec3 $ value "scale" props 140 scale = asVec3 $ value "scale" props
141 141
142 gameIO $ printf "Loading model %s..." name 142 gameIO $ printf "Loading model %s..." name
143 model <- loadModel' file rotation scale 143 model <- loadModel' file rotation scale
144 gameIO . putStrLn $ "done" 144 gameIO . putStrLn $ "done"
145 texture <- loadTexture tex 145 texture <- loadTexture tex
146 sceneRes <- get 146 sceneRes <- get
147 147
148 let material = Material ke ka kd ks shi 148 let material = Material ke ka kd ks shi
149 149
150 case animated model of 150 case animated model of
151 False -> 151 False ->
152 case M.lookup prog $ staticPrograms sceneRes of 152 case M.lookup prog $ staticPrograms sceneRes of
@@ -173,12 +173,12 @@ loadModel' file rotation scale = do
173 (case rotation of 173 (case rotation of
174 Nothing -> Prelude.id 174 Nothing -> Prelude.id
175 Just rot -> rotateModel rot) . 175 Just rot -> rotateModel rot) .
176 176
177 (case scale of 177 (case scale of
178 Nothing -> Prelude.id 178 Nothing -> Prelude.id
179 Just s -> flip Model.transformVerts $ 179 Just s -> flip Model.transformVerts $
180 \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')) 180 \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z'))
181 181
182 (fmap transform $ Model.loadModel file) >>= gameIO . toGround 182 (fmap transform $ Model.loadModel file) >>= gameIO . toGround
183 183
184rotateModel :: Rotation -> Model -> Model 184rotateModel :: Rotation -> Model -> Model
@@ -191,10 +191,10 @@ rotateModel (Rotation ax ay az order) model =
191 ZXY -> rotY ay * rotX ax * rotZ az 191 ZXY -> rotY ay * rotX ax * rotZ az
192 ZYX -> rotX ax * rotY ay * rotZ az 192 ZYX -> rotX ax * rotY ay * rotZ az
193 normalMat = fastNormalMatrix mat 193 normalMat = fastNormalMatrix mat
194 194
195 vTransform (Vec3 x' y' z') = 195 vTransform (Vec3 x' y' z') =
196 let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) 196 let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
197 197
198 nTransform (Vec3 x' y' z') = 198 nTransform (Vec3 x' y' z') =
199 let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) 199 let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
200 in 200 in
@@ -212,9 +212,9 @@ newShaderProgram (SceneLeaf _ props) = do
212 name <- asString $ mandatory' "name" props 212 name <- asString $ mandatory' "name" props
213 stype <- asString $ mandatory' "type" props 213 stype <- asString $ mandatory' "type" props
214 prog <- GL.newProgram [vertShader, fragShader] 214 prog <- GL.newProgram [vertShader, fragShader]
215 215
216 let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name 216 let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name
217 217
218 case stype of 218 case stype of
219 "static" -> do 219 "static" -> do
220 ambient <- asString $ mandatory' "ambient" props 220 ambient <- asString $ mandatory' "ambient" props
@@ -225,7 +225,7 @@ newShaderProgram (SceneLeaf _ props) = do
225 modelview <- asString $ mandatory' "modelview" props 225 modelview <- asString $ mandatory' "modelview" props
226 normalmat <- asString $ mandatory' "normalmat" props 226 normalmat <- asString $ mandatory' "normalmat" props
227 projection <- asString $ mandatory' "projection" props 227 projection <- asString $ mandatory' "projection" props
228 228
229 ka <- getUniformLoc ambient 229 ka <- getUniformLoc ambient
230 kd <- getUniformLoc diffuse 230 kd <- getUniformLoc diffuse
231 ks <- getUniformLoc specular 231 ks <- getUniformLoc specular
@@ -234,18 +234,18 @@ newShaderProgram (SceneLeaf _ props) = do
234 mview <- getUniformLoc modelview 234 mview <- getUniformLoc modelview
235 nmat <- getUniformLoc normalmat 235 nmat <- getUniformLoc normalmat
236 proj <- getUniformLoc projection 236 proj <- getUniformLoc projection
237 237
238 vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props 238 vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props
239 normChan <- fmap read $ asString $ mandatory' "normal-channel" props 239 normChan <- fmap read $ asString $ mandatory' "normal-channel" props
240 texChan <- fmap read $ asString $ mandatory' "texture-channel" props 240 texChan <- fmap read $ asString $ mandatory' "texture-channel" props
241 241
242 let channels = StaticProgramChannels vertChan normChan texChan 242 let channels = StaticProgramChannels vertChan normChan texChan
243 uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj 243 uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj
244 244
245 loadResource name staticPrograms addStaticProgram $ 245 loadResource name staticPrograms addStaticProgram $
246 return $ StaticProgram prog channels uniforms 246 return $ StaticProgram prog channels uniforms
247 return () 247 return ()
248 248
249 "animated" -> do 249 "animated" -> do
250 ambient <- asString $ mandatory' "ambient" props 250 ambient <- asString $ mandatory' "ambient" props
251 diffuse <- asString $ mandatory' "diffuse" props 251 diffuse <- asString $ mandatory' "diffuse" props
@@ -255,7 +255,7 @@ newShaderProgram (SceneLeaf _ props) = do
255 modelview <- asString $ mandatory' "modelview" props 255 modelview <- asString $ mandatory' "modelview" props
256 normalmat <- asString $ mandatory' "normalmat" props 256 normalmat <- asString $ mandatory' "normalmat" props
257 projection <- asString $ mandatory' "projection" props 257 projection <- asString $ mandatory' "projection" props
258 258
259 ka <- getUniformLoc ambient 259 ka <- getUniformLoc ambient
260 kd <- getUniformLoc diffuse 260 kd <- getUniformLoc diffuse
261 ks <- getUniformLoc specular 261 ks <- getUniformLoc specular
@@ -264,7 +264,7 @@ newShaderProgram (SceneLeaf _ props) = do
264 mview <- getUniformLoc modelview 264 mview <- getUniformLoc modelview
265 nmat <- getUniformLoc normalmat 265 nmat <- getUniformLoc normalmat
266 proj <- getUniformLoc projection 266 proj <- getUniformLoc projection
267 267
268 vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props 268 vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props
269 vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props 269 vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props
270 normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props 270 normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props
@@ -272,14 +272,14 @@ newShaderProgram (SceneLeaf _ props) = do
272 texChan <- fmap read $ asString $ mandatory' "texture-channel" props 272 texChan <- fmap read $ asString $ mandatory' "texture-channel" props
273 fp <- asString $ mandatory' "fp" props 273 fp <- asString $ mandatory' "fp" props
274 p <- getUniformLoc fp 274 p <- getUniformLoc fp
275 275
276 let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan 276 let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan
277 uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj 277 uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj
278 278
279 loadResource name animatedPrograms addAnimatedProgram $ 279 loadResource name animatedPrograms addAnimatedProgram $
280 return $ AnimatedProgram prog channels uniforms 280 return $ AnimatedProgram prog channels uniforms
281 return () 281 return ()
282 282
283 _ -> do 283 _ -> do
284 loadResource name customPrograms addCustomProgram $ return prog 284 loadResource name customPrograms addCustomProgram $ return prog
285 return () 285 return ()
@@ -352,10 +352,10 @@ newObject' newGO sceneRes nid props = do
352 right' = (asVec2 $ value "right" props) `unspecified` vec2 1 0 352 right' = (asVec2 $ value "right" props) `unspecified` vec2 1 0
353 up' = asVec2 $ value "up" props 353 up' = asVec2 $ value "up" props
354 scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1 354 scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1
355 355
356 -- Compute the object's vectors if an up/forward vector has been specified. 356 -- Compute the object's vectors if an up/forward vector has been specified.
357 let (right, up) = vectors up' 357 let (right, up) = vectors up'
358 358
359 newGO goType sceneRes props (M3.transform right up position) 359 newGO goType sceneRes props (M3.transform right up position)
360 360
361vectors :: Maybe Vector2 -> (Vector2, Vector2) 361vectors :: Maybe Vector2 -> (Vector2, Vector2)
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 @@
1module Spear.Scene.Scene
2(
3 -- * Data types
4 Scene
5 -- * Construction
6, listScene
7 -- * Insertion and deletion
8, add
9, remove
10, Spear.Scene.Scene.filter
11 -- * Queries
12, find
13, query
14 -- * Update and render
15, update
16, updateM
17, Spear.Scene.Scene.collide
18, collideM
19, render
20)
21where
22
23
24import Spear.Collision
25import Spear.Game (Game)
26import Spear.Math.AABB
27import Spear.Math.QuadTree as QT
28
29import Control.Applicative ((<*>))
30import Control.Monad (foldM)
31import Data.Foldable as F (foldl', mapM_)
32import Data.Functor ((<$>))
33import qualified Data.List as L (delete, filter, find)
34
35
36data Scene obj =
37 ListScene
38 { objects :: ![obj]
39 }
40 |
41 QuadTreeScene
42 { collideAABB :: obj -> AABB -> CollisionType
43 , world :: !(QuadTree obj)
44 }
45
46
47-- | Create a list-based scene.
48listScene :: [obj] -> Scene obj
49listScene = ListScene
50
51
52-- Create an octree-based scene.
53--octreeScene :: (obj -> AABB -> CollisionType) -> (obj -> AABB) -> [obj] -> Scene obj msg
54--octreeScene collide getAABB objs = OctreeScene [] collide $ makeOctree
55
56
57-- | Add a list of game objects to the given 'Scene'.
58add :: Scene obj -> [obj] -> Scene obj
59add (scene@ListScene {}) l = scene { objects = l ++ objects scene }
60add (scene@QuadTreeScene {}) l = scene { world = QT.insert (collideAABB scene) (world scene) l }
61
62
63-- | Remove a game object from the given 'Scene'.
64remove :: Eq obj => Scene obj -> obj -> Scene obj
65remove (scene@ListScene {}) o = scene { objects = L.delete o (objects scene) }
66--remove (scene@OctreeScene {}) o =
67
68
69-- | Remove those game objects that do not satisfy the given predicate from the 'Scene'.
70filter :: (obj -> Bool) -> Scene obj -> Scene obj
71filter pred (scene@ListScene {}) = scene { objects = L.filter pred (objects scene) }
72
73
74-- | Search for an object in the 'Scene'.
75find :: (obj -> Bool) -> Scene obj -> Maybe obj
76find pred (scene@ListScene {}) = L.find pred $ objects scene
77
78
79-- | Return all objects that satisfy the given predicate.
80query :: (obj -> Bool) -> Scene obj -> [obj]
81query pred (scene@ListScene {}) = L.filter pred $ objects scene
82
83
84type Update obj = obj -> obj
85
86
87-- | Update the given scene.
88update :: (obj -> obj) -> Scene obj -> Scene obj
89update updt (scene@ListScene {}) = scene { objects = fmap updt $ objects scene }
90update updt (scene@QuadTreeScene {}) = scene { world = QT.map (collideAABB scene) updt $ world scene }
91
92
93-- | Update the given scene.
94updateM :: Monad m => (obj -> m obj) -> Scene obj -> m (Scene obj)
95updateM updt scene@ListScene {} = mapM updt (objects scene) >>= return . ListScene
96
97
98{-update' :: (obj -> (obj, [a])) -> Scene obj -> (Scene obj, [a])
99
100update' updt (scene@ListScene {}) =
101 let (objs, msgs) = unzip . fmap updt $ objects scene
102 in (scene { objects = objs }, concat msgs)-}
103
104
105-- | Perform collisions.
106collide :: ([obj] -> obj -> obj) -> Scene obj -> Scene obj
107
108collide col scene@ListScene {} =
109 let objs = objects scene
110 objs' = fmap (col objs) objs
111 in
112 scene { objects = objs' }
113
114collide col scene@QuadTreeScene {} = error "not yet implemented"
115 --scene { world = gmap (collideAABB scene) col $ world scene }
116
117
118-- | Perform collisions.
119collideM :: Monad m => (obj -> obj -> m obj) -> Scene obj -> m (Scene obj)
120collideM col scene@ListScene {} =
121 let objs = objects scene
122
123 col' o = foldM f o objs
124 f o p = col o p
125
126 objs' = sequence . fmap col' $ objs
127 in
128 objs' >>= return . ListScene
129
130
131{-collide' :: (obj -> obj -> (obj, [a])) -> Scene obj -> (Scene obj, [a])
132
133collide' col scene@ListScene {} =
134 let objs = objects scene
135
136 --col' :: obj -> (obj, [a])
137 col' o = foldl' f (o, []) objs
138
139 --f :: (obj, [a]) -> obj -> (obj, [a])
140 f (o, msgs) p = let (o', msgs') = col o p in (o', msgs' ++ msgs)
141
142 (objs', msgs) = let (os, ms) = (unzip . fmap col' $ objs) in (os, concat ms)
143 in
144 (scene { objects = objs' }, msgs)-}
145
146
147-- | Render the given 'Scene'.
148render :: (obj -> Game s ()) -> Scene obj -> Game s ()
149render rend (scene@ListScene {}) = Prelude.mapM_ rend $ objects scene
150render rend (scene@QuadTreeScene {}) = F.mapM_ rend $ world scene
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-25 11:59:48 +0000