diff options
-rw-r--r-- | Spear.cabal | 32 | ||||
-rw-r--r-- | Spear.lkshs | 12 | ||||
-rw-r--r-- | Spear/Collision/Collision.hs | 79 | ||||
-rw-r--r-- | Spear/Collision/Collisioner.hs | 52 | ||||
-rw-r--r-- | Spear/Math/AABB.hs | 12 | ||||
-rw-r--r-- | Spear/Math/Circle.hs | 33 | ||||
-rw-r--r-- | Spear/Math/Octree.hs | 284 | ||||
-rw-r--r-- | Spear/Math/QuadTree.hs | 248 | ||||
-rw-r--r-- | Spear/Math/Sphere.hs | 35 | ||||
-rw-r--r-- | Spear/Scene/Scene.hs | 4 |
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 | |||
6 | license-file: LICENSE | 6 | license-file: LICENSE |
7 | maintainer: jeannekamikaze@gmail.com | 7 | maintainer: jeannekamikaze@gmail.com |
8 | homepage: http://spear.shellblade.net | 8 | homepage: http://spear.shellblade.net |
9 | synopsis: A 3D game framework. | 9 | synopsis: A 2.5D game framework. |
10 | category: Game | 10 | category: Game |
11 | author: Marc Sunet | 11 | author: Marc Sunet |
12 | data-dir: "" | 12 | data-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 @@ | |||
1 | Version of session file format: | 1 | Version of session file format: |
2 | 1 | 2 | 1 |
3 | Time of storage: | 3 | Time of storage: |
4 | "Tue Aug 28 17:22:50 CEST 2012" | 4 | "Tue Aug 28 18:24:30 CEST 2012" |
5 | Layout: 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 | 5 | Layout: 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 |
6 | Population: [(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])] | 6 | Population: [(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])] |
7 | Window size: (1820,939) | 7 | Window size: (1820,939) |
8 | Completion size: | 8 | Completion size: |
9 | (750,400) | 9 | (750,400) |
10 | Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" | 10 | Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" |
11 | Active pane: Just "Workspace" | 11 | Active pane: Just "Modules" |
12 | Toolbar visible: | 12 | Toolbar visible: |
13 | True | 13 | True |
14 | FindbarState: (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}) | 14 | FindbarState: (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}) |
15 | Recently opened files: | 15 | Recently 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"] |
17 | Recently opened workspaces: | 17 | Recently 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 @@ | |||
1 | module Spear.Collision.Collision | 1 | module Spear.Collision.Collision |
2 | ( | 2 | ( |
3 | Collisionable(..) | 3 | Collisionable(..) |
4 | , aabbFromSphere | 4 | , aabbFromCircle |
5 | ) | 5 | ) |
6 | where | 6 | where |
7 | 7 | ||
8 | 8 | ||
9 | import Spear.Collision.Types | 9 | import Spear.Collision.Types |
10 | import Spear.Math.AABB | 10 | import Spear.Math.AABB |
11 | import Spear.Math.Sphere | 11 | import Spear.Math.Circle |
12 | import Spear.Math.Plane | 12 | import Spear.Math.Plane |
13 | import Spear.Math.Vector3 | 13 | import Spear.Math.Vector2 |
14 | 14 | ||
15 | 15 | ||
16 | class Collisionable a where | 16 | class 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 | ||
22 | instance Collisionable AABB where | 21 | instance 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 | ||
54 | instance Collisionable Sphere where | 45 | instance 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 | ||
73 | aabbPoints :: AABB -> [Vector3] | 63 | aabbPoints :: AABB -> [Vector2] |
74 | aabbPoints (AABB min max) = [p1,p2,p3,p4,p5,p6,p7,p8] | 64 | aabbPoints (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. |
87 | aabbFromSphere :: Sphere -> AABB | 77 | aabbFromCircle :: Circle -> AABB |
88 | aabbFromSphere (Sphere c r) = AABB bot top | 78 | aabbFromCircle (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 | ||
96 | aabb = 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 | |||
13 | import Spear.Collision.Collision as C | 13 | import Spear.Collision.Collision as C |
14 | import Spear.Collision.Types | 14 | import Spear.Collision.Types |
15 | import Spear.Math.AABB | 15 | import Spear.Math.AABB |
16 | import Spear.Math.Sphere | 16 | import Spear.Math.Circle |
17 | import Spear.Math.Vector3 | 17 | import 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'. |
34 | sphereCollisioner :: Sphere -> Collisioner | 34 | sphereCollisioner :: Circle -> Collisioner |
35 | sphereCollisioner = SphereCol | 35 | sphereCollisioner = 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. |
39 | buildAABB :: [Collisioner] -> AABB | 39 | buildAABB :: [Collisioner] -> AABB |
40 | buildAABB cols = aabb $ Spear.Collision.Collisioner.generatePoints cols | 40 | buildAABB 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'. |
44 | boxFromSphere :: Sphere -> Collisioner | 44 | boxFromSphere :: Circle -> Collisioner |
45 | boxFromSphere = AABBCol . aabbFromSphere | 45 | boxFromSphere = AABBCol . aabbFromCircle |
46 | 46 | ||
47 | 47 | ||
48 | generatePoints :: [Collisioner] -> [Vector3] | 48 | generatePoints :: [Collisioner] -> [Vector2] |
49 | generatePoints = foldr generate [] | 49 | generatePoints = 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. |
73 | collide :: Collisioner -> Collisioner -> CollisionType | 71 | collide :: Collisioner -> Collisioner -> CollisionType |
74 | collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2 | 72 | collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2 |
75 | collide (SphereCol s1) (SphereCol s2) = collideSphere s1 s2 | 73 | collide (CircleCol s1) (CircleCol s2) = collideSphere s1 s2 |
76 | collide (AABBCol box) (SphereCol sphere) = collideBox box sphere | 74 | collide (AABBCol box) (CircleCol sphere) = collideBox box sphere |
77 | collide (SphereCol sphere) (AABBCol box) = collideSphere sphere box | 75 | collide (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 | |||
7 | where | 7 | where |
8 | 8 | ||
9 | 9 | ||
10 | import Spear.Math.Vector3 as Vector | 10 | import Spear.Math.Vector2 |
11 | 11 | ||
12 | 12 | ||
13 | -- | An axis-aligned bounding box. | 13 | -- | An axis-aligned bounding box. |
14 | data AABB = AABB {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 | 14 | data 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. |
18 | aabb :: [Vector3] -> AABB | 18 | aabb :: [Vector2] -> AABB |
19 | 19 | ||
20 | aabb [] = error "Attempting to build a BoundingVolume from an empty list!" | 20 | aabb [] = error "Attempting to build a BoundingVolume from an empty list!" |
21 | 21 | ||
22 | aabb (x:xs) = foldr update (AABB x x) xs | 22 | aabb (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. |
27 | aabbpt :: AABB -> Vector3 -> Bool | 27 | aabbpt :: AABB -> Vector2 -> Bool |
28 | (AABB min max) `aabbpt` v = v >= min && v <= max | 28 | aabbpt (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 @@ | |||
1 | module Spear.Math.Circle | ||
2 | ( | ||
3 | Circle(..) | ||
4 | , circle | ||
5 | , circlept | ||
6 | ) | ||
7 | where | ||
8 | |||
9 | |||
10 | import Spear.Math.Vector2 | ||
11 | |||
12 | |||
13 | -- | A bounding volume. | ||
14 | data Circle = Circle | ||
15 | { center :: {-# UNPACK #-} !Vector2 | ||
16 | , radius :: {-# UNPACK #-} !Float | ||
17 | } | ||
18 | |||
19 | |||
20 | -- | Create a 'Sphere' from the given points. | ||
21 | circle :: [Vector2] -> Circle | ||
22 | circle [] = error "Attempting to build a Circle from an empty list!" | ||
23 | circle (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. | ||
32 | circlept :: Circle -> Vector2 -> Bool | ||
33 | circlept (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 @@ | |||
1 | module 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 | ) | ||
12 | where | ||
13 | |||
14 | import Spear.Collision.Types | ||
15 | import Spear.Math.AABB | ||
16 | import Spear.Math.Vector3 | ||
17 | |||
18 | import Control.Applicative ((<*>)) | ||
19 | import Data.List | ||
20 | import Data.Functor | ||
21 | import Data.Monoid | ||
22 | import qualified Data.Foldable as F | ||
23 | |||
24 | |||
25 | -- | Represents an Octree. | ||
26 | data 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. | ||
49 | makeOctree :: Int -> AABB -> Octree e | ||
50 | makeOctree 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 | |||
65 | subdivide :: AABB -> [AABB] | ||
66 | subdivide (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. | ||
81 | clone :: Octree e -> Octree e | ||
82 | clone (Leaf root ents) = Leaf root [] | ||
83 | clone (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 | |||
95 | keep :: (e -> AABB -> CollisionType) -> AABB -> e -> Bool | ||
96 | keep testAABB aabb e = test == FullyContainedBy | ||
97 | where test = e `testAABB` aabb | ||
98 | |||
99 | |||
100 | -- | Inserts an entity into the given octree. | ||
101 | insert :: (e -> AABB -> CollisionType) -> Octree e -> e -> Octree e | ||
102 | insert testAABB octree e = octree' where (octree', _) = insert' testAABB e octree | ||
103 | |||
104 | |||
105 | insert' :: (e -> AABB -> CollisionType) -> e -> Octree e -> (Octree e, Bool) | ||
106 | |||
107 | |||
108 | insert' 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 | |||
115 | insert' 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. | ||
137 | insertl :: (e -> AABB -> CollisionType) -> Octree e -> [e] -> Octree e | ||
138 | insertl testAABB octree es = octree' where (octree', _) = insertl' testAABB es octree | ||
139 | |||
140 | |||
141 | insertl' :: (e -> AABB -> CollisionType) -> [e] -> Octree e -> (Octree e, [e]) | ||
142 | |||
143 | insertl' 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 | |||
149 | insertl' 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. | ||
167 | extract :: Octree e -> (Octree e, [e]) | ||
168 | extract (Leaf root ents) = (Leaf root [], ents) | ||
169 | extract (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. | ||
184 | map :: (e -> AABB -> CollisionType) -> (e -> e) -> Octree e -> Octree e | ||
185 | map testAABB f o = let (o', outliers) = map' testAABB f o in insertl testAABB o' outliers | ||
186 | |||
187 | |||
188 | map' :: (e -> AABB -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e]) | ||
189 | |||
190 | |||
191 | map' 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 | |||
198 | map' 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. | ||
216 | gmap :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e | ||
217 | gmap testAABB f o = let (o', outliers) = gmap' testAABB f o in insertl testAABB o' outliers | ||
218 | |||
219 | |||
220 | gmap' :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e]) | ||
221 | |||
222 | gmap' 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 | |||
228 | gmap' 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 | |||
244 | population :: Octree e -> Int | ||
245 | population = F.foldr (\_ acc -> acc+1) 0 | ||
246 | |||
247 | |||
248 | |||
249 | |||
250 | instance 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 | |||
268 | instance 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 @@ | |||
1 | module Spear.Math.QuadTree | ||
2 | ( | ||
3 | QuadTree | ||
4 | , makeQuadTree | ||
5 | , clone | ||
6 | , Spear.Math.QuadTree.insert | ||
7 | , Spear.Math.QuadTree.map | ||
8 | , gmap | ||
9 | ) | ||
10 | where | ||
11 | |||
12 | import Spear.Collision.Types | ||
13 | import Spear.Math.AABB | ||
14 | import Spear.Math.Vector2 | ||
15 | |||
16 | import Control.Applicative ((<*>)) | ||
17 | import Data.List | ||
18 | import Data.Functor | ||
19 | import Data.Monoid | ||
20 | import qualified Data.Foldable as F | ||
21 | |||
22 | |||
23 | -- | Represents an QuadTree. | ||
24 | data 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. | ||
45 | makeQuadTree :: Int -> AABB -> QuadTree e | ||
46 | makeQuadTree 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 | |||
61 | subdivide :: AABB -> [AABB] | ||
62 | subdivide (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. | ||
77 | clone :: QuadTree e -> QuadTree e | ||
78 | clone (Leaf root ents) = Leaf root [] | ||
79 | clone (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 | |||
91 | keep :: (e -> AABB -> CollisionType) -> AABB -> e -> Bool | ||
92 | keep testAABB aabb e = test == FullyContainedBy | ||
93 | where test = e `testAABB` aabb | ||
94 | |||
95 | |||
96 | -- | Inserts a list of entities into the given octree. | ||
97 | insert :: (e -> AABB -> CollisionType) -> QuadTree e -> [e] -> QuadTree e | ||
98 | insert testAABB octree es = octree' where (octree', _) = insert' testAABB es octree | ||
99 | |||
100 | |||
101 | insert' :: (e -> AABB -> CollisionType) -> [e] -> QuadTree e -> (QuadTree e, [e]) | ||
102 | |||
103 | insert' 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 | |||
109 | insert' 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. | ||
127 | extract :: QuadTree e -> (QuadTree e, [e]) | ||
128 | extract (Leaf root ents) = (Leaf root [], ents) | ||
129 | extract (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. | ||
144 | map :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> QuadTree e | ||
145 | map testAABB f o = | ||
146 | let (o', outliers) = map' testAABB f o | ||
147 | in Spear.Math.QuadTree.insert testAABB o' outliers | ||
148 | |||
149 | |||
150 | map' :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> (QuadTree e, [e]) | ||
151 | |||
152 | |||
153 | map' 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 | |||
160 | map' 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. | ||
178 | gmap :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> QuadTree e | ||
179 | gmap testAABB f o = | ||
180 | let (o', outliers) = gmap' testAABB f o | ||
181 | in Spear.Math.QuadTree.insert testAABB o' outliers | ||
182 | |||
183 | |||
184 | gmap' :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> (QuadTree e, [e]) | ||
185 | |||
186 | gmap' 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 | |||
192 | gmap' 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 | |||
208 | population :: QuadTree e -> Int | ||
209 | population = F.foldr (\_ acc -> acc+1) 0 | ||
210 | |||
211 | |||
212 | |||
213 | |||
214 | instance 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 | |||
232 | instance 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 @@ | |||
1 | module Spear.Math.Sphere | ||
2 | ( | ||
3 | Sphere(..) | ||
4 | , sphere | ||
5 | , spherept | ||
6 | ) | ||
7 | where | ||
8 | |||
9 | |||
10 | import Spear.Math.Vector3 as Vector | ||
11 | |||
12 | |||
13 | -- | A bounding volume. | ||
14 | data Sphere = Sphere | ||
15 | { center :: {-# UNPACK #-} !Vector3 | ||
16 | , radius :: {-# UNPACK #-} !Float | ||
17 | } | ||
18 | |||
19 | |||
20 | -- | Create a 'Sphere' from the given points. | ||
21 | sphere :: [Vector3] -> Sphere | ||
22 | |||
23 | sphere [] = error "Attempting to build a BoundingVolume from an empty list!" | ||
24 | |||
25 | sphere (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. | ||
34 | spherept :: 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 @@ | |||
1 | module Spear.Scene.Scene | 1 | module Spear.Scene.Scene |
2 | where | ||
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 {} = | |||
150 | render :: (obj -> Game s ()) -> Scene obj -> Game s () | 153 | render :: (obj -> Game s ()) -> Scene obj -> Game s () |
151 | render rend (scene@ListScene {}) = Prelude.mapM_ rend $ objects scene | 154 | render rend (scene@ListScene {}) = Prelude.mapM_ rend $ objects scene |
152 | render rend (scene@OctreeScene {}) = F.mapM_ rend $ world scene | 155 | render rend (scene@OctreeScene {}) = F.mapM_ rend $ world scene |
156 | -} \ No newline at end of file | ||