aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Spear.cabal32
-rw-r--r--Spear.lkshs12
-rw-r--r--Spear/Collision/Collision.hs79
-rw-r--r--Spear/Collision/Collisioner.hs52
-rw-r--r--Spear/Math/AABB.hs12
-rw-r--r--Spear/Math/Circle.hs33
-rw-r--r--Spear/Math/Octree.hs284
-rw-r--r--Spear/Math/QuadTree.hs248
-rw-r--r--Spear/Math/Sphere.hs35
-rw-r--r--Spear/Scene/Scene.hs4
10 files changed, 360 insertions, 431 deletions
diff --git a/Spear.cabal b/Spear.cabal
index acad880..ffe11dc 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -6,7 +6,7 @@ license: BSD3
6license-file: LICENSE 6license-file: LICENSE
7maintainer: jeannekamikaze@gmail.com 7maintainer: jeannekamikaze@gmail.com
8homepage: http://spear.shellblade.net 8homepage: http://spear.shellblade.net
9synopsis: A 3D game framework. 9synopsis: A 2.5D game framework.
10category: Game 10category: Game
11author: Marc Sunet 11author: Marc Sunet
12data-dir: "" 12data-dir: ""
@@ -16,24 +16,24 @@ library
16 StateVar -any, base -any, bytestring -any, directory -any, 16 StateVar -any, base -any, bytestring -any, directory -any,
17 mtl -any, transformers -any, resourcet -any, parsec >=3.1.3, 17 mtl -any, transformers -any, resourcet -any, parsec >=3.1.3,
18 containers -any, vector -any, array -any 18 containers -any, vector -any, array -any
19 exposed-modules: Spear.Physics.Types Spear.App 19 exposed-modules: Spear.Math.QuadTree Spear.Physics.Types Spear.App
20 Spear.App.Application Spear.App.Input Spear.Assets.Image 20 Spear.App.Application Spear.App.Input Spear.Assets.Image
21 Spear.Assets.Model Spear.Collision Spear.Math.AABB 21 Spear.Assets.Model Spear.Collision Spear.Math.AABB
22 Spear.Collision.Collision Spear.Collision.Collisioner 22 Spear.Collision.Collision Spear.Collision.Collisioner
23 Spear.Math.Sphere Spear.Math.Triangle 23 Spear.Math.Circle Spear.Math.Triangle Spear.Collision.Types
24 Spear.Collision.Types Spear.Game Spear.GLSL Spear.GLSL.Buffer 24 Spear.Game Spear.GLSL Spear.GLSL.Buffer Spear.GLSL.Error
25 Spear.GLSL.Error Spear.GLSL.Management Spear.GLSL.Texture 25 Spear.GLSL.Management Spear.GLSL.Texture Spear.GLSL.Uniform
26 Spear.GLSL.Uniform Spear.GLSL.VAO Spear.Math.Camera 26 Spear.GLSL.VAO Spear.Math.Camera Spear.Math.Entity
27 Spear.Math.Entity Spear.Math.Matrix3 Spear.Math.Matrix4 27 Spear.Math.Matrix3 Spear.Math.Matrix4 Spear.Math.MatrixUtils
28 Spear.Math.MatrixUtils Spear.Math.Octree Spear.Math.Plane 28 Spear.Math.Plane Spear.Math.Quaternion Spear.Math.Spatial
29 Spear.Math.Quaternion Spear.Math.Spatial Spear.Math.Vector3 29 Spear.Math.Vector3 Spear.Math.Vector4 Spear.Physics
30 Spear.Math.Vector4 Spear.Physics Spear.Physics.Rigid 30 Spear.Physics.Rigid Spear.Render.AnimatedModel
31 Spear.Render.AnimatedModel Spear.Render.Material Spear.Render.Model 31 Spear.Render.Material Spear.Render.Model Spear.Render.Program
32 Spear.Render.Program Spear.Render.Renderable 32 Spear.Render.Renderable Spear.Render.StaticModel
33 Spear.Render.StaticModel Spear.Render.Texture Spear.Scene.Graph 33 Spear.Render.Texture Spear.Scene.Graph Spear.Scene.Light
34 Spear.Scene.Light Spear.Scene.Loader Spear.Scene.Scene 34 Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources
35 Spear.Scene.SceneResources Spear.Setup Spear.Sys.Timer 35 Spear.Setup Spear.Sys.Timer Spear.Sys.Store Spear.Sys.Store.ID
36 Spear.Sys.Store Spear.Sys.Store.ID Spear.Updatable Spear.Math.Vector2 36 Spear.Updatable Spear.Math.Vector2
37 exposed: True 37 exposed: True
38 buildable: True 38 buildable: True
39 build-tools: hsc2hs -any 39 build-tools: hsc2hs -any
diff --git a/Spear.lkshs b/Spear.lkshs
index 9aa6160..2663b79 100644
--- a/Spear.lkshs
+++ b/Spear.lkshs
@@ -1,18 +1,18 @@
1Version of session file format: 1Version of session file format:
2 1 2 1
3Time of storage: 3Time of storage:
4 "Tue Aug 28 17:22:50 CEST 2012" 4 "Tue Aug 28 18:24:30 CEST 2012"
5Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = -1, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 247) 202)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 691) 954 5Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = -1, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 240) 199)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 696) 954
6Population: [(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (InfoSt (InfoState (Just (Real (RealDescr {dscName' = "map", dscMbTypeStr' = Just "map ::\n (e -> AABB -> CollisionType) -> (e -> e) -> Octree e -> Octree e", dscMbModu' = Just (PM {pack = PackageIdentifier {pkgName = PackageName "Spear", pkgVersion = Version {versionBranch = [0,1], versionTags = []}}, modu = ModuleName ["Spear","Math","Octree"]}), dscMbLocation' = Just (Location {locationSLine = 185, locationSCol = 1, locationELine = 185, locationECol = 90}), dscMbComment' = Just " Applies the given function to the entities in the octree.\n Entities that break out of their cell are reallocated appropriately.", dscTypeHint' = VariableDescr, dscExported' = False}))))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 328 (PackageScope False,False) (Just (ModuleName ["Spear","Math","Octree"]),Just "map") (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([[0,4],[0,1],[0]],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP])] 6Population: [(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 328 (PackageScope False,False) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([[0]],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP])]
7Window size: (1820,939) 7Window size: (1820,939)
8Completion size: 8Completion size:
9 (750,400) 9 (750,400)
10Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" 10Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw"
11Active pane: Just "Workspace" 11Active pane: Just "Modules"
12Toolbar visible: 12Toolbar visible:
13 True 13 True
14FindbarState: (False,FindState {entryStr = "asd", entryHist = ["idxs","asd","elemIndexa","elemtIn","splitAt","allocaBytes","copyArray","allocaArray","allocaa","putStrLn","assigned","Triangle"], replaceStr = "objects", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) 14FindbarState: (False,FindState {entryStr = "asad", entryHist = ["asad","Octree","idxs","asd","elemIndexa","elemtIn","splitAt","allocaBytes","copyArray","allocaArray","allocaa","putStrLn"], replaceStr = "QuadTree", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = False, regex = False, lineNr = 1})
15Recently opened files: 15Recently opened files:
16 ["/home/jeanne/programming/haskell/Spear/Spear/Collision/Types.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Triangle.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Sphere.hs","/home/jeanne/programming/haskell/Spear/Spear/Scene/Scene.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collisioner.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/AABB.hs","/home/jeanne/programming/haskell/Spear/demos/simple-scene/Game/GameObject/Factory.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Octree.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collision.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision.hs","/home/jeanne/programming/haskell/Spear/Spear/Physics.hs","/home/jeanne/programming/haskell/Spear/Spear/Physics/World.hs"] 16 ["/home/jeanne/programming/haskell/Spear/Spear/Math/AABB.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Circle.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collision.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collisioner.hs","/home/jeanne/programming/haskell/Spear/Spear/Scene/Scene.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/QuadTree.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Sphere.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Triangle.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Spatial.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Quaternion.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Plane.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Octree.hs"]
17Recently opened workspaces: 17Recently opened workspaces:
18 ["/home/jeanne/programming/haskell/hagen/hagen.lkshw","/home/jeanne/programming/haskell/foo/foo.lkshw","/home/jeanne/programming/haskell/Spear/Spear.lkshw","/home/jeanne/programming/haskell/nexus/nexus.lkshw","/home/jeanne/leksah.lkshw"] \ No newline at end of file 18 ["/home/jeanne/programming/haskell/hagen/hagen.lkshw","/home/jeanne/programming/haskell/foo/foo.lkshw","/home/jeanne/programming/haskell/Spear/Spear.lkshw","/home/jeanne/programming/haskell/nexus/nexus.lkshw","/home/jeanne/leksah.lkshw"] \ No newline at end of file
diff --git a/Spear/Collision/Collision.hs b/Spear/Collision/Collision.hs
index 08f33b5..3a4c614 100644
--- a/Spear/Collision/Collision.hs
+++ b/Spear/Collision/Collision.hs
@@ -1,22 +1,21 @@
1module Spear.Collision.Collision 1module Spear.Collision.Collision
2( 2(
3 Collisionable(..) 3 Collisionable(..)
4, aabbFromSphere 4, aabbFromCircle
5) 5)
6where 6where
7 7
8 8
9import Spear.Collision.Types 9import Spear.Collision.Types
10import Spear.Math.AABB 10import Spear.Math.AABB
11import Spear.Math.Sphere 11import Spear.Math.Circle
12import Spear.Math.Plane 12import Spear.Math.Plane
13import Spear.Math.Vector3 13import Spear.Math.Vector2
14 14
15 15
16class Collisionable a where 16class Collisionable a where
17 collideBox :: AABB -> a -> CollisionType 17 collideBox :: AABB -> a -> CollisionType
18 collideSphere :: Sphere -> a -> CollisionType 18 collideSphere :: Circle -> a -> CollisionType
19 collidePlane :: Plane -> a -> CollisionType
20 19
21 20
22instance Collisionable AABB where 21instance Collisionable AABB where
@@ -30,35 +29,27 @@ instance Collisionable AABB where
30 | (x min1) > (x max2) = NoCollision 29 | (x min1) > (x max2) = NoCollision
31 | (y max1) < (y min2) = NoCollision 30 | (y max1) < (y min2) = NoCollision
32 | (y min1) > (y max2) = NoCollision 31 | (y min1) > (y max2) = NoCollision
33 | (z max1) < (z min2) = NoCollision
34 | (z min1) > (z max2) = NoCollision
35 | otherwise = Collision 32 | otherwise = Collision
36 33
37 collideSphere sphere@(Sphere c r) aabb@(AABB min max) 34 collideSphere sphere@(Circle c r) aabb@(AABB min max)
38 | test == FullyContains || test == FullyContainedBy = test 35 | test == FullyContains || test == FullyContainedBy = test
39 | normSq (c - boxC) > (l + r)^2 = NoCollision 36 | normSq (c - boxC) > (l + r)^2 = NoCollision
40 | otherwise = Collision 37 | otherwise = Collision
41 where 38 where
42 test = aabb `collideBox` aabbFromSphere sphere 39 test = aabb `collideBox` aabbFromCircle sphere
43 boxC = min + (max-min)/2 40 boxC = min + (max-min)/2
44 l = norm $ min + (vec3 (x boxC) (y min) (z min)) - min 41 l = norm $ min + (vec2 (x boxC) (y min)) - min
45 42
46 collidePlane pl aabb@(AABB {})
47 | sameSide tests = NoCollision
48 | otherwise = Collision
49 where
50 tests = fmap (classify pl) $ aabbPoints aabb
51 sameSide (x:xs) = all (==x) xs
52 43
53 44
54instance Collisionable Sphere where 45instance Collisionable Circle where
55 46
56 collideBox box sphere = case collideSphere sphere box of 47 collideBox box sphere = case collideSphere sphere box of
57 FullyContains -> FullyContainedBy 48 FullyContains -> FullyContainedBy
58 FullyContainedBy -> FullyContains 49 FullyContainedBy -> FullyContains
59 x -> x 50 x -> x
60 51
61 collideSphere s1@(Sphere c1 r1) s2@(Sphere c2 r2) 52 collideSphere s1@(Circle c1 r1) s2@(Circle c2 r2)
62 | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy 53 | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy
63 | distance_centers <= sum_radii = Collision 54 | distance_centers <= sum_radii = Collision
64 | otherwise = NoCollision 55 | otherwise = NoCollision
@@ -67,50 +58,24 @@ instance Collisionable Sphere where
67 sum_radii = (r1 + r2)^2 58 sum_radii = (r1 + r2)^2
68 sub_radii = (r1 - r2)^2 59 sub_radii = (r1 - r2)^2
69 60
70 collidePlane pl s = NoCollision
71 61
72 62
73aabbPoints :: AABB -> [Vector3] 63aabbPoints :: AABB -> [Vector2]
74aabbPoints (AABB min max) = [p1,p2,p3,p4,p5,p6,p7,p8] 64aabbPoints (AABB min max) = [p1,p2,p3,p4,p5,p6,p7,p8]
75 where 65 where
76 p1 = vec3 (x min) (y min) (z min) 66 p1 = vec2 (x min) (y min)
77 p2 = vec3 (x min) (y min) (z max) 67 p2 = vec2 (x min) (y min)
78 p3 = vec3 (x min) (y max) (z min) 68 p3 = vec2 (x min) (y max)
79 p4 = vec3 (x min) (y max) (z max) 69 p4 = vec2 (x min) (y max)
80 p5 = vec3 (x max) (y min) (z min) 70 p5 = vec2 (x max) (y min)
81 p6 = vec3 (x max) (y min) (z max) 71 p6 = vec2 (x max) (y min)
82 p7 = vec3 (x max) (y max) (z min) 72 p7 = vec2 (x max) (y max)
83 p8 = vec3 (x max) (y max) (z max) 73 p8 = vec2 (x max) (y max)
84 74
85 75
86-- | Create the minimal AABB fully containing the specified Sphere. 76-- | Create the minimal AABB fully containing the specified Sphere.
87aabbFromSphere :: Sphere -> AABB 77aabbFromCircle :: Circle -> AABB
88aabbFromSphere (Sphere c r) = AABB bot top 78aabbFromCircle (Circle c r) = AABB bot top
89 where
90 bot = c - (vec3 r r r)
91 top = c + (vec3 r r r)
92
93
94-- | Create the minimal AABB fully containing the specified 'BoundingVolume's.
95{-aabb :: [BoundingVolume] -> BoundingVolume
96aabb = Spear.Collision.BoundingVolume.fromList BoundingBox . foldr generate []
97 where 79 where
98 generate (AABB min max) acc = p1:p2:p3:p4:p5:p6:p7:p8:acc 80 bot = c - (vec2 r r)
99 where 81 top = c + (vec2 r r)
100 p1 = vec3 (x min) (y min) (z min)
101 p2 = vec3 (x min) (y min) (z max)
102 p3 = vec3 (x min) (y max) (z min)
103 p4 = vec3 (x min) (y max) (z max)
104 p5 = vec3 (x max) (y min) (z min)
105 p6 = vec3 (x max) (y min) (z max)
106 p7 = vec3 (x max) (y max) (z min)
107 p8 = vec3 (x max) (y max) (z max)
108
109 generate (Sphere c r) acc = p1:p2:p3:p4:p5:p6:acc
110 where
111 p1 = c + unitX * (vec3 r r r)
112 p2 = c - unitX * (vec3 r r r)
113 p3 = c + unitY * (vec3 r r r)
114 p4 = c - unitY * (vec3 r r r)
115 p5 = c + unitZ * (vec3 r r r)
116 p6 = c - unitZ * (vec3 r r r)-}
diff --git a/Spear/Collision/Collisioner.hs b/Spear/Collision/Collisioner.hs
index 266244d..af6fee5 100644
--- a/Spear/Collision/Collisioner.hs
+++ b/Spear/Collision/Collisioner.hs
@@ -13,8 +13,8 @@ where
13import Spear.Collision.Collision as C 13import Spear.Collision.Collision as C
14import Spear.Collision.Types 14import Spear.Collision.Types
15import Spear.Math.AABB 15import Spear.Math.AABB
16import Spear.Math.Sphere 16import Spear.Math.Circle
17import Spear.Math.Vector3 17import Spear.Math.Vector2
18 18
19 19
20-- | A collisioner component. 20-- | A collisioner component.
@@ -22,7 +22,7 @@ data Collisioner
22 -- | An axis-aligned bounding box. 22 -- | An axis-aligned bounding box.
23 = AABBCol { getBox :: !AABB } 23 = AABBCol { getBox :: !AABB }
24 -- | A bounding sphere. 24 -- | A bounding sphere.
25 | SphereCol { getSphere :: !Sphere } 25 | CircleCol { getSphere :: !Circle }
26 26
27 27
28-- | Create a 'Collisioner' from the specified 'AABB'. 28-- | Create a 'Collisioner' from the specified 'AABB'.
@@ -31,47 +31,45 @@ aabbCollisioner = AABBCol
31 31
32 32
33-- | Create a 'Collisioner' from the specified 'BSphere'. 33-- | Create a 'Collisioner' from the specified 'BSphere'.
34sphereCollisioner :: Sphere -> Collisioner 34sphereCollisioner :: Circle -> Collisioner
35sphereCollisioner = SphereCol 35sphereCollisioner = CircleCol
36 36
37 37
38-- | Create the minimal 'AABB' fully containing the specified collisioners. 38-- | Create the minimal 'AABB' fully containing the specified collisioners.
39buildAABB :: [Collisioner] -> AABB 39buildAABB :: [Collisioner] -> AABB
40buildAABB cols = aabb $ Spear.Collision.Collisioner.generatePoints cols 40buildAABB cols = aabb $ generatePoints cols
41 41
42 42
43-- | Create the minimal 'AABB' collisioner fully containing the specified 'BSphere'. 43-- | Create the minimal 'AABB' collisioner fully containing the specified 'BSphere'.
44boxFromSphere :: Sphere -> Collisioner 44boxFromSphere :: Circle -> Collisioner
45boxFromSphere = AABBCol . aabbFromSphere 45boxFromSphere = AABBCol . aabbFromCircle
46 46
47 47
48generatePoints :: [Collisioner] -> [Vector3] 48generatePoints :: [Collisioner] -> [Vector2]
49generatePoints = foldr generate [] 49generatePoints = foldr generate []
50 where 50 where
51 generate (AABBCol (AABB min max)) acc = p1:p2:p3:p4:p5:p6:p7:p8:acc 51 generate (AABBCol (AABB min max)) acc = p1:p2:p3:p4:p5:p6:p7:p8:acc
52 where 52 where
53 p1 = vec3 (x min) (y min) (z min) 53 p1 = vec2 (x min) (y min)
54 p2 = vec3 (x min) (y min) (z max) 54 p2 = vec2 (x min) (y min)
55 p3 = vec3 (x min) (y max) (z min) 55 p3 = vec2 (x min) (y max)
56 p4 = vec3 (x min) (y max) (z max) 56 p4 = vec2 (x min) (y max)
57 p5 = vec3 (x max) (y min) (z min) 57 p5 = vec2 (x max) (y min)
58 p6 = vec3 (x max) (y min) (z max) 58 p6 = vec2 (x max) (y min)
59 p7 = vec3 (x max) (y max) (z min) 59 p7 = vec2 (x max) (y max)
60 p8 = vec3 (x max) (y max) (z max) 60 p8 = vec2 (x max) (y max)
61 61
62 generate (SphereCol (Sphere c r)) acc = p1:p2:p3:p4:p5:p6:acc 62 generate (CircleCol (Circle c r)) acc = p1:p2:p3:p4:acc
63 where 63 where
64 p1 = c + unitX * (vec3 r r r) 64 p1 = c + unitx * (vec2 r r)
65 p2 = c - unitX * (vec3 r r r) 65 p2 = c - unitx * (vec2 r r)
66 p3 = c + unitY * (vec3 r r r) 66 p3 = c + unity * (vec2 r r)
67 p4 = c - unitY * (vec3 r r r) 67 p4 = c - unity * (vec2 r r)
68 p5 = c + unitZ * (vec3 r r r)
69 p6 = c - unitZ * (vec3 r r r)
70 68
71 69
72-- | Collide the given collisioners. 70-- | Collide the given collisioners.
73collide :: Collisioner -> Collisioner -> CollisionType 71collide :: Collisioner -> Collisioner -> CollisionType
74collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2 72collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2
75collide (SphereCol s1) (SphereCol s2) = collideSphere s1 s2 73collide (CircleCol s1) (CircleCol s2) = collideSphere s1 s2
76collide (AABBCol box) (SphereCol sphere) = collideBox box sphere 74collide (AABBCol box) (CircleCol sphere) = collideBox box sphere
77collide (SphereCol sphere) (AABBCol box) = collideSphere sphere box 75collide (CircleCol sphere) (AABBCol box) = collideSphere sphere box
diff --git a/Spear/Math/AABB.hs b/Spear/Math/AABB.hs
index 362ddd6..55e3083 100644
--- a/Spear/Math/AABB.hs
+++ b/Spear/Math/AABB.hs
@@ -7,22 +7,22 @@ module Spear.Math.AABB
7where 7where
8 8
9 9
10import Spear.Math.Vector3 as Vector 10import Spear.Math.Vector2
11 11
12 12
13-- | An axis-aligned bounding box. 13-- | An axis-aligned bounding box.
14data AABB = AABB {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 14data AABB = AABB {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2
15 15
16 16
17-- | Create a 'AABB' from the given points. 17-- | Create a 'AABB' from the given points.
18aabb :: [Vector3] -> AABB 18aabb :: [Vector2] -> AABB
19 19
20aabb [] = error "Attempting to build a BoundingVolume from an empty list!" 20aabb [] = error "Attempting to build a BoundingVolume from an empty list!"
21 21
22aabb (x:xs) = foldr update (AABB x x) xs 22aabb (x:xs) = foldr update (AABB x x) xs
23 where update p (AABB min max) = AABB (Vector.min p min) (Vector.max p max) 23 where update p (AABB min max) = AABB (v2min p min) (v2max p max)
24 24
25 25
26-- | Return 'True' if the given 'AABB' contains the given point, 'False' otherwise. 26-- | Return 'True' if the given 'AABB' contains the given point, 'False' otherwise.
27aabbpt :: AABB -> Vector3 -> Bool 27aabbpt :: AABB -> Vector2 -> Bool
28(AABB min max) `aabbpt` v = v >= min && v <= max 28aabbpt (AABB min max) v = v >= min && v <= max
diff --git a/Spear/Math/Circle.hs b/Spear/Math/Circle.hs
new file mode 100644
index 0000000..a34de0b
--- /dev/null
+++ b/Spear/Math/Circle.hs
@@ -0,0 +1,33 @@
1module Spear.Math.Circle
2(
3 Circle(..)
4, circle
5, circlept
6)
7where
8
9
10import Spear.Math.Vector2
11
12
13-- | A bounding volume.
14data Circle = Circle
15 { center :: {-# UNPACK #-} !Vector2
16 , radius :: {-# UNPACK #-} !Float
17 }
18
19
20-- | Create a 'Sphere' from the given points.
21circle :: [Vector2] -> Circle
22circle [] = error "Attempting to build a Circle from an empty list!"
23circle (x:xs) = Circle c r
24 where
25 c = min + (max-min)/2
26 r = norm $ max - c
27 (min,max) = foldr update (x,x) xs
28 update p (min,max) = (v2min p min, v2max p max)
29
30
31-- | Return 'True' if the given 'Sphere' contains the given point, 'False' otherwise.
32circlept :: Circle -> Vector2 -> Bool
33circlept (Circle c r) p = r*r >= normSq (p - c)
diff --git a/Spear/Math/Octree.hs b/Spear/Math/Octree.hs
deleted file mode 100644
index 15f7dde..0000000
--- a/Spear/Math/Octree.hs
+++ /dev/null
@@ -1,284 +0,0 @@
1module Spear.Math.Octree
2(
3 Octree
4, makeOctree
5, clone
6, Spear.Math.Octree.insert
7, insertl
8, Spear.Math.Octree.map
9, gmap
10, population
11)
12where
13
14import Spear.Collision.Types
15import Spear.Math.AABB
16import Spear.Math.Vector3
17
18import Control.Applicative ((<*>))
19import Data.List
20import Data.Functor
21import Data.Monoid
22import qualified Data.Foldable as F
23
24
25-- | Represents an Octree.
26data Octree e
27 = Octree
28 {
29 root :: !AABB,
30 ents :: ![e],
31 c1 :: !(Octree e),
32 c2 :: !(Octree e),
33 c3 :: !(Octree e),
34 c4 :: !(Octree e),
35 c5 :: !(Octree e),
36 c6 :: !(Octree e),
37 c7 :: !(Octree e),
38 c8 :: !(Octree e)
39 }
40 |
41 Leaf
42 {
43 root :: !AABB,
44 ents :: ![e]
45 }
46
47
48-- | Builds an Octree using the specified AABB as the root and having the specified depth.
49makeOctree :: Int -> AABB -> Octree e
50makeOctree d root@(AABB min max)
51 | d == 0 = Leaf root []
52 | otherwise = Octree root [] c1 c2 c3 c4 c5 c6 c7 c8
53 where
54 boxes = subdivide root
55 c1 = makeOctree (d-1) $ boxes !! 0
56 c2 = makeOctree (d-1) $ boxes !! 1
57 c3 = makeOctree (d-1) $ boxes !! 2
58 c4 = makeOctree (d-1) $ boxes !! 3
59 c5 = makeOctree (d-1) $ boxes !! 4
60 c6 = makeOctree (d-1) $ boxes !! 5
61 c7 = makeOctree (d-1) $ boxes !! 6
62 c8 = makeOctree (d-1) $ boxes !! 7
63
64
65subdivide :: AABB -> [AABB]
66subdivide (AABB min max) = [a1, a2, a3, a4, a5, a6, a7, a8]
67 where
68 v = (max-min) / 2
69 c = vec3 (x min + x v) (y min + y v) (z min + z v)
70 a1 = AABB min c
71 a2 = AABB ( vec3 (x min) (y min) (z c) ) ( vec3 (x c) (y c) (z max) )
72 a3 = AABB ( vec3 (x min) (y c) (z min) ) ( vec3 (x c) (y max) (z c) )
73 a4 = AABB ( vec3 (x min) (y c) (z c) ) ( vec3 (x c) (y max) (z max) )
74 a5 = AABB ( vec3 (x c) (y min) (z min) ) ( vec3 (x max) (y c) (z c) )
75 a6 = AABB ( vec3 (x c) (y min) (z c) ) ( vec3 (x max) (y c) (z max) )
76 a7 = AABB ( vec3 (x c) (y c) (z min) ) ( vec3 (x max) (y max) (z c) )
77 a8 = AABB c max
78
79
80-- | Clones the structure of an octree. The new octree has no entities.
81clone :: Octree e -> Octree e
82clone (Leaf root ents) = Leaf root []
83clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8'
84 where
85 c1' = clone c1
86 c2' = clone c2
87 c3' = clone c3
88 c4' = clone c4
89 c5' = clone c5
90 c6' = clone c6
91 c7' = clone c7
92 c8' = clone c8
93
94
95keep :: (e -> AABB -> CollisionType) -> AABB -> e -> Bool
96keep testAABB aabb e = test == FullyContainedBy
97 where test = e `testAABB` aabb
98
99
100-- | Inserts an entity into the given octree.
101insert :: (e -> AABB -> CollisionType) -> Octree e -> e -> Octree e
102insert testAABB octree e = octree' where (octree', _) = insert' testAABB e octree
103
104
105insert' :: (e -> AABB -> CollisionType) -> e -> Octree e -> (Octree e, Bool)
106
107
108insert' testAABB e l@(Leaf root ents)
109 | test == True = (Leaf root (e:ents), True)
110 | otherwise = (l, False)
111 where
112 test = keep testAABB root e
113
114
115insert' testAABB e o@(Octree root ents c1 c2 c3 c4 c5 c6 c7 c8)
116 | test == False = (o, False)
117 | otherwise =
118 if isContainedInChild then (Octree root ents c1' c2' c3' c4' c5' c6' c7' c8', True)
119 else (Octree root (e:ents) c1 c2 c3 c4 c5 c6 c7 c8, True)
120 where
121 children = [c1,c2,c3,c4,c5,c6,c7,c8]
122 test = keep testAABB root e
123 descend = fmap (Spear.Math.Octree.insert' testAABB e) children
124 (children', results) = unzip descend
125 isContainedInChild = or results
126 c1' = children' !! 0
127 c2' = children' !! 1
128 c3' = children' !! 2
129 c4' = children' !! 3
130 c5' = children' !! 4
131 c6' = children' !! 5
132 c7' = children' !! 6
133 c8' = children' !! 7
134
135
136-- | Inserts a list of entities into the given octree.
137insertl :: (e -> AABB -> CollisionType) -> Octree e -> [e] -> Octree e
138insertl testAABB octree es = octree' where (octree', _) = insertl' testAABB es octree
139
140
141insertl' :: (e -> AABB -> CollisionType) -> [e] -> Octree e -> (Octree e, [e])
142
143insertl' testAABB es (Leaf root ents) = (Leaf root ents', outliers)
144 where
145 ents' = ents ++ ents_kept
146 ents_kept = filter (keep testAABB root) es
147 outliers = filter (not . keep testAABB root) es
148
149insertl' testAABB es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
150 (Octree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers)
151 where
152 ents' = ents ++ ents_kept
153 new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8
154 ents_kept = filter (keep testAABB root) new_ents
155 outliers = filter (not . keep testAABB root) new_ents
156 (c1', ents1) = insertl' testAABB es c1
157 (c2', ents2) = insertl' testAABB es c2
158 (c3', ents3) = insertl' testAABB es c3
159 (c4', ents4) = insertl' testAABB es c4
160 (c5', ents5) = insertl' testAABB es c5
161 (c6', ents6) = insertl' testAABB es c6
162 (c7', ents7) = insertl' testAABB es c7
163 (c8', ents8) = insertl' testAABB es c8
164
165
166-- | Extracts all entities from an octree. The resulting octree has no entities.
167extract :: Octree e -> (Octree e, [e])
168extract (Leaf root ents) = (Leaf root [], ents)
169extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents')
170 where
171 (c1', ents1) = extract c1
172 (c2', ents2) = extract c2
173 (c3', ents3) = extract c3
174 (c4', ents4) = extract c4
175 (c5', ents5) = extract c5
176 (c6', ents6) = extract c6
177 (c7', ents7) = extract c7
178 (c8', ents8) = extract c8
179 ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8
180
181
182-- | Applies the given function to the entities in the octree.
183-- Entities that break out of their cell are reallocated appropriately.
184map :: (e -> AABB -> CollisionType) -> (e -> e) -> Octree e -> Octree e
185map testAABB f o = let (o', outliers) = map' testAABB f o in insertl testAABB o' outliers
186
187
188map' :: (e -> AABB -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e])
189
190
191map' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers)
192 where
193 ents' = fmap f ents
194 ents_kept = filter (keep testAABB root) ents'
195 outliers = filter (not . keep testAABB root) ents'
196
197
198map' testAABB f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
199 (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers)
200 where
201 ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8
202 ents_kept = filter (keep testAABB root) ents'
203 outliers = filter (not . keep testAABB root) ents'
204 (c1', out1) = map' testAABB f c1
205 (c2', out2) = map' testAABB f c2
206 (c3', out3) = map' testAABB f c3
207 (c4', out4) = map' testAABB f c4
208 (c5', out5) = map' testAABB f c5
209 (c6', out6) = map' testAABB f c6
210 (c7', out7) = map' testAABB f c7
211 (c8', out8) = map' testAABB f c8
212
213
214-- | Applies a function to the entity groups in the octree.
215-- Entities that break out of their cell are reallocated appropriately.
216gmap :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e
217gmap testAABB f o = let (o', outliers) = gmap' testAABB f o in insertl testAABB o' outliers
218
219
220gmap' :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e])
221
222gmap' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers)
223 where
224 ents' = f <$> ents <*> ents
225 ents_kept = filter (keep testAABB root) ents'
226 outliers = filter (not . keep testAABB root) ents'
227
228gmap' testAABB f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
229 (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers)
230 where
231 ents' = (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8
232 ents_kept = filter (keep testAABB root) ents'
233 outliers = filter (not . keep testAABB root) ents'
234 (c1', out1) = gmap' testAABB f c1
235 (c2', out2) = gmap' testAABB f c2
236 (c3', out3) = gmap' testAABB f c3
237 (c4', out4) = gmap' testAABB f c4
238 (c5', out5) = gmap' testAABB f c5
239 (c6', out6) = gmap' testAABB f c6
240 (c7', out7) = gmap' testAABB f c7
241 (c8', out8) = gmap' testAABB f c8
242
243
244population :: Octree e -> Int
245population = F.foldr (\_ acc -> acc+1) 0
246
247
248
249
250instance Functor Octree where
251
252 fmap f (Leaf root ents) = Leaf root $ fmap f ents
253
254 fmap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
255 Octree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8'
256 where
257 c1' = fmap f c1
258 c2' = fmap f c2
259 c3' = fmap f c3
260 c4' = fmap f c4
261 c5' = fmap f c5
262 c6' = fmap f c6
263 c7' = fmap f c7
264 c8' = fmap f c8
265
266
267
268instance F.Foldable Octree where
269
270 foldMap f (Leaf root ents) = mconcat . fmap f $ ents
271
272 foldMap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) =
273 mconcat (fmap f ents) `mappend`
274 c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend`
275 c5' `mappend` c6' `mappend` c7' `mappend` c8'
276 where
277 c1' = F.foldMap f c1
278 c2' = F.foldMap f c2
279 c3' = F.foldMap f c3
280 c4' = F.foldMap f c4
281 c5' = F.foldMap f c5
282 c6' = F.foldMap f c6
283 c7' = F.foldMap f c7
284 c8' = F.foldMap f c8
diff --git a/Spear/Math/QuadTree.hs b/Spear/Math/QuadTree.hs
new file mode 100644
index 0000000..2e92265
--- /dev/null
+++ b/Spear/Math/QuadTree.hs
@@ -0,0 +1,248 @@
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.Types
13import Spear.Math.AABB
14import Spear.Math.Vector2
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
deleted file mode 100644
index 4a9e3fc..0000000
--- a/Spear/Math/Sphere.hs
+++ /dev/null
@@ -1,35 +0,0 @@
1module Spear.Math.Sphere
2(
3 Sphere(..)
4, sphere
5, spherept
6)
7where
8
9
10import Spear.Math.Vector3 as Vector
11
12
13-- | A bounding volume.
14data Sphere = Sphere
15 { center :: {-# UNPACK #-} !Vector3
16 , radius :: {-# UNPACK #-} !Float
17 }
18
19
20-- | Create a 'Sphere' from the given points.
21sphere :: [Vector3] -> Sphere
22
23sphere [] = error "Attempting to build a BoundingVolume from an empty list!"
24
25sphere (x:xs) = Sphere c r
26 where
27 c = min + (max-min)/2
28 r = norm $ max - c
29 (min,max) = foldr update (x,x) xs
30 update p (min,max) = (Vector.min p min, Vector.max p max)
31
32
33-- | Return 'True' if the given 'Sphere' contains the given point, 'False' otherwise.
34spherept :: Sphere -> Vector3 -> Bool
35(Sphere center radius) `spherept` p = radius*radius >= normSq (p - center)
diff --git a/Spear/Scene/Scene.hs b/Spear/Scene/Scene.hs
index fe0eff8..4658ddb 100644
--- a/Spear/Scene/Scene.hs
+++ b/Spear/Scene/Scene.hs
@@ -1,4 +1,7 @@
1module Spear.Scene.Scene 1module Spear.Scene.Scene
2where
3
4{-module Spear.Scene.Scene
2( 5(
3 -- * Data types 6 -- * Data types
4 Scene 7 Scene
@@ -150,3 +153,4 @@ collide' col scene@ListScene {} =
150render :: (obj -> Game s ()) -> Scene obj -> Game s () 153render :: (obj -> Game s ()) -> Scene obj -> Game s ()
151render rend (scene@ListScene {}) = Prelude.mapM_ rend $ objects scene 154render rend (scene@ListScene {}) = Prelude.mapM_ rend $ objects scene
152render rend (scene@OctreeScene {}) = F.mapM_ rend $ world scene 155render rend (scene@OctreeScene {}) = F.mapM_ rend $ world scene
156-} \ No newline at end of file
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 05:47:55 +0000