From 8c6c0bbe54a179350f1ecd6d7c227245133ecc7d Mon Sep 17 00:00:00 2001 From: Marc Sunet Date: Tue, 28 Aug 2012 18:25:27 +0200 Subject: Translated collision and collision entities to 2D --- Spear.cabal | 32 ++--- Spear.lkshs | 12 +- Spear/Collision/Collision.hs | 79 ++++-------- Spear/Collision/Collisioner.hs | 52 ++++---- Spear/Math/AABB.hs | 12 +- Spear/Math/Circle.hs | 33 +++++ Spear/Math/Octree.hs | 284 ----------------------------------------- Spear/Math/QuadTree.hs | 248 +++++++++++++++++++++++++++++++++++ Spear/Math/Sphere.hs | 35 ----- Spear/Scene/Scene.hs | 4 + 10 files changed, 360 insertions(+), 431 deletions(-) create mode 100644 Spear/Math/Circle.hs delete mode 100644 Spear/Math/Octree.hs create mode 100644 Spear/Math/QuadTree.hs delete mode 100644 Spear/Math/Sphere.hs diff --git a/Spear.cabal b/Spear.cabal index acad880..ffe11dc 100644 --- a/Spear.cabal +++ b/Spear.cabal @@ -6,7 +6,7 @@ license: BSD3 license-file: LICENSE maintainer: jeannekamikaze@gmail.com homepage: http://spear.shellblade.net -synopsis: A 3D game framework. +synopsis: A 2.5D game framework. category: Game author: Marc Sunet data-dir: "" @@ -16,24 +16,24 @@ library StateVar -any, base -any, bytestring -any, directory -any, mtl -any, transformers -any, resourcet -any, parsec >=3.1.3, containers -any, vector -any, array -any - exposed-modules: Spear.Physics.Types Spear.App + exposed-modules: Spear.Math.QuadTree Spear.Physics.Types Spear.App Spear.App.Application Spear.App.Input Spear.Assets.Image Spear.Assets.Model Spear.Collision Spear.Math.AABB Spear.Collision.Collision Spear.Collision.Collisioner - Spear.Math.Sphere Spear.Math.Triangle - Spear.Collision.Types Spear.Game Spear.GLSL Spear.GLSL.Buffer - Spear.GLSL.Error Spear.GLSL.Management Spear.GLSL.Texture - Spear.GLSL.Uniform Spear.GLSL.VAO Spear.Math.Camera - Spear.Math.Entity Spear.Math.Matrix3 Spear.Math.Matrix4 - Spear.Math.MatrixUtils Spear.Math.Octree Spear.Math.Plane - Spear.Math.Quaternion Spear.Math.Spatial Spear.Math.Vector3 - Spear.Math.Vector4 Spear.Physics Spear.Physics.Rigid - Spear.Render.AnimatedModel Spear.Render.Material Spear.Render.Model - Spear.Render.Program Spear.Render.Renderable - Spear.Render.StaticModel Spear.Render.Texture Spear.Scene.Graph - Spear.Scene.Light Spear.Scene.Loader Spear.Scene.Scene - Spear.Scene.SceneResources Spear.Setup Spear.Sys.Timer - Spear.Sys.Store Spear.Sys.Store.ID Spear.Updatable Spear.Math.Vector2 + Spear.Math.Circle Spear.Math.Triangle Spear.Collision.Types + Spear.Game Spear.GLSL Spear.GLSL.Buffer Spear.GLSL.Error + Spear.GLSL.Management Spear.GLSL.Texture Spear.GLSL.Uniform + Spear.GLSL.VAO Spear.Math.Camera Spear.Math.Entity + Spear.Math.Matrix3 Spear.Math.Matrix4 Spear.Math.MatrixUtils + Spear.Math.Plane Spear.Math.Quaternion Spear.Math.Spatial + Spear.Math.Vector3 Spear.Math.Vector4 Spear.Physics + Spear.Physics.Rigid Spear.Render.AnimatedModel + Spear.Render.Material Spear.Render.Model Spear.Render.Program + Spear.Render.Renderable Spear.Render.StaticModel + Spear.Render.Texture Spear.Scene.Graph Spear.Scene.Light + Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources + Spear.Setup Spear.Sys.Timer Spear.Sys.Store Spear.Sys.Store.ID + Spear.Updatable Spear.Math.Vector2 exposed: True buildable: True 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 @@ Version of session file format: 1 Time of storage: - "Tue Aug 28 17:22:50 CEST 2012" -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 -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])] + "Tue Aug 28 18:24:30 CEST 2012" +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 +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])] Window size: (1820,939) Completion size: (750,400) Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" -Active pane: Just "Workspace" +Active pane: Just "Modules" Toolbar visible: True -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}) +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}) Recently opened files: - ["/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"] + ["/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"] Recently opened workspaces: ["/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 @@ module Spear.Collision.Collision ( Collisionable(..) -, aabbFromSphere +, aabbFromCircle ) where import Spear.Collision.Types import Spear.Math.AABB -import Spear.Math.Sphere +import Spear.Math.Circle import Spear.Math.Plane -import Spear.Math.Vector3 +import Spear.Math.Vector2 class Collisionable a where collideBox :: AABB -> a -> CollisionType - collideSphere :: Sphere -> a -> CollisionType - collidePlane :: Plane -> a -> CollisionType + collideSphere :: Circle -> a -> CollisionType instance Collisionable AABB where @@ -30,35 +29,27 @@ instance Collisionable AABB where | (x min1) > (x max2) = NoCollision | (y max1) < (y min2) = NoCollision | (y min1) > (y max2) = NoCollision - | (z max1) < (z min2) = NoCollision - | (z min1) > (z max2) = NoCollision | otherwise = Collision - collideSphere sphere@(Sphere c r) aabb@(AABB min max) + collideSphere sphere@(Circle c r) aabb@(AABB min max) | test == FullyContains || test == FullyContainedBy = test | normSq (c - boxC) > (l + r)^2 = NoCollision | otherwise = Collision where - test = aabb `collideBox` aabbFromSphere sphere + test = aabb `collideBox` aabbFromCircle sphere boxC = min + (max-min)/2 - l = norm $ min + (vec3 (x boxC) (y min) (z min)) - min + l = norm $ min + (vec2 (x boxC) (y min)) - min - collidePlane pl aabb@(AABB {}) - | sameSide tests = NoCollision - | otherwise = Collision - where - tests = fmap (classify pl) $ aabbPoints aabb - sameSide (x:xs) = all (==x) xs -instance Collisionable Sphere where +instance Collisionable Circle where collideBox box sphere = case collideSphere sphere box of FullyContains -> FullyContainedBy FullyContainedBy -> FullyContains x -> x - collideSphere s1@(Sphere c1 r1) s2@(Sphere c2 r2) + collideSphere s1@(Circle c1 r1) s2@(Circle c2 r2) | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy | distance_centers <= sum_radii = Collision | otherwise = NoCollision @@ -67,50 +58,24 @@ instance Collisionable Sphere where sum_radii = (r1 + r2)^2 sub_radii = (r1 - r2)^2 - collidePlane pl s = NoCollision -aabbPoints :: AABB -> [Vector3] +aabbPoints :: AABB -> [Vector2] aabbPoints (AABB min max) = [p1,p2,p3,p4,p5,p6,p7,p8] where - p1 = vec3 (x min) (y min) (z min) - p2 = vec3 (x min) (y min) (z max) - p3 = vec3 (x min) (y max) (z min) - p4 = vec3 (x min) (y max) (z max) - p5 = vec3 (x max) (y min) (z min) - p6 = vec3 (x max) (y min) (z max) - p7 = vec3 (x max) (y max) (z min) - p8 = vec3 (x max) (y max) (z max) + p1 = vec2 (x min) (y min) + p2 = vec2 (x min) (y min) + p3 = vec2 (x min) (y max) + p4 = vec2 (x min) (y max) + p5 = vec2 (x max) (y min) + p6 = vec2 (x max) (y min) + p7 = vec2 (x max) (y max) + p8 = vec2 (x max) (y max) -- | Create the minimal AABB fully containing the specified Sphere. -aabbFromSphere :: Sphere -> AABB -aabbFromSphere (Sphere c r) = AABB bot top - where - bot = c - (vec3 r r r) - top = c + (vec3 r r r) - - --- | Create the minimal AABB fully containing the specified 'BoundingVolume's. -{-aabb :: [BoundingVolume] -> BoundingVolume -aabb = Spear.Collision.BoundingVolume.fromList BoundingBox . foldr generate [] +aabbFromCircle :: Circle -> AABB +aabbFromCircle (Circle c r) = AABB bot top where - generate (AABB min max) acc = p1:p2:p3:p4:p5:p6:p7:p8:acc - where - p1 = vec3 (x min) (y min) (z min) - p2 = vec3 (x min) (y min) (z max) - p3 = vec3 (x min) (y max) (z min) - p4 = vec3 (x min) (y max) (z max) - p5 = vec3 (x max) (y min) (z min) - p6 = vec3 (x max) (y min) (z max) - p7 = vec3 (x max) (y max) (z min) - p8 = vec3 (x max) (y max) (z max) - - generate (Sphere c r) acc = p1:p2:p3:p4:p5:p6:acc - where - p1 = c + unitX * (vec3 r r r) - p2 = c - unitX * (vec3 r r r) - p3 = c + unitY * (vec3 r r r) - p4 = c - unitY * (vec3 r r r) - p5 = c + unitZ * (vec3 r r r) - p6 = c - unitZ * (vec3 r r r)-} + bot = c - (vec2 r r) + top = c + (vec2 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 import Spear.Collision.Collision as C import Spear.Collision.Types import Spear.Math.AABB -import Spear.Math.Sphere -import Spear.Math.Vector3 +import Spear.Math.Circle +import Spear.Math.Vector2 -- | A collisioner component. @@ -22,7 +22,7 @@ data Collisioner -- | An axis-aligned bounding box. = AABBCol { getBox :: !AABB } -- | A bounding sphere. - | SphereCol { getSphere :: !Sphere } + | CircleCol { getSphere :: !Circle } -- | Create a 'Collisioner' from the specified 'AABB'. @@ -31,47 +31,45 @@ aabbCollisioner = AABBCol -- | Create a 'Collisioner' from the specified 'BSphere'. -sphereCollisioner :: Sphere -> Collisioner -sphereCollisioner = SphereCol +sphereCollisioner :: Circle -> Collisioner +sphereCollisioner = CircleCol -- | Create the minimal 'AABB' fully containing the specified collisioners. buildAABB :: [Collisioner] -> AABB -buildAABB cols = aabb $ Spear.Collision.Collisioner.generatePoints cols +buildAABB cols = aabb $ generatePoints cols -- | Create the minimal 'AABB' collisioner fully containing the specified 'BSphere'. -boxFromSphere :: Sphere -> Collisioner -boxFromSphere = AABBCol . aabbFromSphere +boxFromSphere :: Circle -> Collisioner +boxFromSphere = AABBCol . aabbFromCircle -generatePoints :: [Collisioner] -> [Vector3] +generatePoints :: [Collisioner] -> [Vector2] generatePoints = foldr generate [] where generate (AABBCol (AABB min max)) acc = p1:p2:p3:p4:p5:p6:p7:p8:acc where - p1 = vec3 (x min) (y min) (z min) - p2 = vec3 (x min) (y min) (z max) - p3 = vec3 (x min) (y max) (z min) - p4 = vec3 (x min) (y max) (z max) - p5 = vec3 (x max) (y min) (z min) - p6 = vec3 (x max) (y min) (z max) - p7 = vec3 (x max) (y max) (z min) - p8 = vec3 (x max) (y max) (z max) + p1 = vec2 (x min) (y min) + p2 = vec2 (x min) (y min) + p3 = vec2 (x min) (y max) + p4 = vec2 (x min) (y max) + p5 = vec2 (x max) (y min) + p6 = vec2 (x max) (y min) + p7 = vec2 (x max) (y max) + p8 = vec2 (x max) (y max) - generate (SphereCol (Sphere c r)) acc = p1:p2:p3:p4:p5:p6:acc + generate (CircleCol (Circle c r)) acc = p1:p2:p3:p4:acc where - p1 = c + unitX * (vec3 r r r) - p2 = c - unitX * (vec3 r r r) - p3 = c + unitY * (vec3 r r r) - p4 = c - unitY * (vec3 r r r) - p5 = c + unitZ * (vec3 r r r) - p6 = c - unitZ * (vec3 r r r) + p1 = c + unitx * (vec2 r r) + p2 = c - unitx * (vec2 r r) + p3 = c + unity * (vec2 r r) + p4 = c - unity * (vec2 r r) -- | Collide the given collisioners. collide :: Collisioner -> Collisioner -> CollisionType collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2 -collide (SphereCol s1) (SphereCol s2) = collideSphere s1 s2 -collide (AABBCol box) (SphereCol sphere) = collideBox box sphere -collide (SphereCol sphere) (AABBCol box) = collideSphere sphere box +collide (CircleCol s1) (CircleCol s2) = collideSphere s1 s2 +collide (AABBCol box) (CircleCol sphere) = collideBox box sphere +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 where -import Spear.Math.Vector3 as Vector +import Spear.Math.Vector2 -- | An axis-aligned bounding box. -data AABB = AABB {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 +data AABB = AABB {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 -- | Create a 'AABB' from the given points. -aabb :: [Vector3] -> AABB +aabb :: [Vector2] -> AABB aabb [] = error "Attempting to build a BoundingVolume from an empty list!" aabb (x:xs) = foldr update (AABB x x) xs - where update p (AABB min max) = AABB (Vector.min p min) (Vector.max p max) + where update p (AABB min max) = AABB (v2min p min) (v2max p max) -- | Return 'True' if the given 'AABB' contains the given point, 'False' otherwise. -aabbpt :: AABB -> Vector3 -> Bool -(AABB min max) `aabbpt` v = v >= min && v <= max +aabbpt :: AABB -> Vector2 -> Bool +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 @@ +module Spear.Math.Circle +( + Circle(..) +, circle +, circlept +) +where + + +import Spear.Math.Vector2 + + +-- | A bounding volume. +data Circle = Circle + { center :: {-# UNPACK #-} !Vector2 + , radius :: {-# UNPACK #-} !Float + } + + +-- | Create a 'Sphere' from the given points. +circle :: [Vector2] -> Circle +circle [] = error "Attempting to build a Circle from an empty list!" +circle (x:xs) = Circle c r + where + c = min + (max-min)/2 + r = norm $ max - c + (min,max) = foldr update (x,x) xs + update p (min,max) = (v2min p min, v2max p max) + + +-- | Return 'True' if the given 'Sphere' contains the given point, 'False' otherwise. +circlept :: Circle -> Vector2 -> Bool +circlept (Circle c r) p = r*r >= normSq (p - c) diff --git a/Spear/Math/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 @@ -module Spear.Math.Octree -( - Octree -, makeOctree -, clone -, Spear.Math.Octree.insert -, insertl -, Spear.Math.Octree.map -, gmap -, population -) -where - -import Spear.Collision.Types -import Spear.Math.AABB -import Spear.Math.Vector3 - -import Control.Applicative ((<*>)) -import Data.List -import Data.Functor -import Data.Monoid -import qualified Data.Foldable as F - - --- | Represents an Octree. -data Octree e - = Octree - { - root :: !AABB, - ents :: ![e], - c1 :: !(Octree e), - c2 :: !(Octree e), - c3 :: !(Octree e), - c4 :: !(Octree e), - c5 :: !(Octree e), - c6 :: !(Octree e), - c7 :: !(Octree e), - c8 :: !(Octree e) - } - | - Leaf - { - root :: !AABB, - ents :: ![e] - } - - --- | Builds an Octree using the specified AABB as the root and having the specified depth. -makeOctree :: Int -> AABB -> Octree e -makeOctree d root@(AABB min max) - | d == 0 = Leaf root [] - | otherwise = Octree root [] c1 c2 c3 c4 c5 c6 c7 c8 - where - boxes = subdivide root - c1 = makeOctree (d-1) $ boxes !! 0 - c2 = makeOctree (d-1) $ boxes !! 1 - c3 = makeOctree (d-1) $ boxes !! 2 - c4 = makeOctree (d-1) $ boxes !! 3 - c5 = makeOctree (d-1) $ boxes !! 4 - c6 = makeOctree (d-1) $ boxes !! 5 - c7 = makeOctree (d-1) $ boxes !! 6 - c8 = makeOctree (d-1) $ boxes !! 7 - - -subdivide :: AABB -> [AABB] -subdivide (AABB min max) = [a1, a2, a3, a4, a5, a6, a7, a8] - where - v = (max-min) / 2 - c = vec3 (x min + x v) (y min + y v) (z min + z v) - a1 = AABB min c - a2 = AABB ( vec3 (x min) (y min) (z c) ) ( vec3 (x c) (y c) (z max) ) - a3 = AABB ( vec3 (x min) (y c) (z min) ) ( vec3 (x c) (y max) (z c) ) - a4 = AABB ( vec3 (x min) (y c) (z c) ) ( vec3 (x c) (y max) (z max) ) - a5 = AABB ( vec3 (x c) (y min) (z min) ) ( vec3 (x max) (y c) (z c) ) - a6 = AABB ( vec3 (x c) (y min) (z c) ) ( vec3 (x max) (y c) (z max) ) - a7 = AABB ( vec3 (x c) (y c) (z min) ) ( vec3 (x max) (y max) (z c) ) - a8 = AABB c max - - --- | Clones the structure of an octree. The new octree has no entities. -clone :: Octree e -> Octree e -clone (Leaf root ents) = Leaf root [] -clone (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = Octree root [] c1' c2' c3' c4' c5' c6' c7' c8' - where - c1' = clone c1 - c2' = clone c2 - c3' = clone c3 - c4' = clone c4 - c5' = clone c5 - c6' = clone c6 - c7' = clone c7 - c8' = clone c8 - - -keep :: (e -> AABB -> CollisionType) -> AABB -> e -> Bool -keep testAABB aabb e = test == FullyContainedBy - where test = e `testAABB` aabb - - --- | Inserts an entity into the given octree. -insert :: (e -> AABB -> CollisionType) -> Octree e -> e -> Octree e -insert testAABB octree e = octree' where (octree', _) = insert' testAABB e octree - - -insert' :: (e -> AABB -> CollisionType) -> e -> Octree e -> (Octree e, Bool) - - -insert' testAABB e l@(Leaf root ents) - | test == True = (Leaf root (e:ents), True) - | otherwise = (l, False) - where - test = keep testAABB root e - - -insert' testAABB e o@(Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) - | test == False = (o, False) - | otherwise = - if isContainedInChild then (Octree root ents c1' c2' c3' c4' c5' c6' c7' c8', True) - else (Octree root (e:ents) c1 c2 c3 c4 c5 c6 c7 c8, True) - where - children = [c1,c2,c3,c4,c5,c6,c7,c8] - test = keep testAABB root e - descend = fmap (Spear.Math.Octree.insert' testAABB e) children - (children', results) = unzip descend - isContainedInChild = or results - c1' = children' !! 0 - c2' = children' !! 1 - c3' = children' !! 2 - c4' = children' !! 3 - c5' = children' !! 4 - c6' = children' !! 5 - c7' = children' !! 6 - c8' = children' !! 7 - - --- | Inserts a list of entities into the given octree. -insertl :: (e -> AABB -> CollisionType) -> Octree e -> [e] -> Octree e -insertl testAABB octree es = octree' where (octree', _) = insertl' testAABB es octree - - -insertl' :: (e -> AABB -> CollisionType) -> [e] -> Octree e -> (Octree e, [e]) - -insertl' testAABB es (Leaf root ents) = (Leaf root ents', outliers) - where - ents' = ents ++ ents_kept - ents_kept = filter (keep testAABB root) es - outliers = filter (not . keep testAABB root) es - -insertl' testAABB es (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (Octree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers) - where - ents' = ents ++ ents_kept - new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 - ents_kept = filter (keep testAABB root) new_ents - outliers = filter (not . keep testAABB root) new_ents - (c1', ents1) = insertl' testAABB es c1 - (c2', ents2) = insertl' testAABB es c2 - (c3', ents3) = insertl' testAABB es c3 - (c4', ents4) = insertl' testAABB es c4 - (c5', ents5) = insertl' testAABB es c5 - (c6', ents6) = insertl' testAABB es c6 - (c7', ents7) = insertl' testAABB es c7 - (c8', ents8) = insertl' testAABB es c8 - - --- | Extracts all entities from an octree. The resulting octree has no entities. -extract :: Octree e -> (Octree e, [e]) -extract (Leaf root ents) = (Leaf root [], ents) -extract (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (Octree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents') - where - (c1', ents1) = extract c1 - (c2', ents2) = extract c2 - (c3', ents3) = extract c3 - (c4', ents4) = extract c4 - (c5', ents5) = extract c5 - (c6', ents6) = extract c6 - (c7', ents7) = extract c7 - (c8', ents8) = extract c8 - ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 - - --- | Applies the given function to the entities in the octree. --- Entities that break out of their cell are reallocated appropriately. -map :: (e -> AABB -> CollisionType) -> (e -> e) -> Octree e -> Octree e -map testAABB f o = let (o', outliers) = map' testAABB f o in insertl testAABB o' outliers - - -map' :: (e -> AABB -> CollisionType) -> (e -> e) -> Octree e -> (Octree e, [e]) - - -map' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers) - where - ents' = fmap f ents - ents_kept = filter (keep testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - - -map' testAABB f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) - where - ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 - ents_kept = filter (keep testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - (c1', out1) = map' testAABB f c1 - (c2', out2) = map' testAABB f c2 - (c3', out3) = map' testAABB f c3 - (c4', out4) = map' testAABB f c4 - (c5', out5) = map' testAABB f c5 - (c6', out6) = map' testAABB f c6 - (c7', out7) = map' testAABB f c7 - (c8', out8) = map' testAABB f c8 - - --- | Applies a function to the entity groups in the octree. --- Entities that break out of their cell are reallocated appropriately. -gmap :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> Octree e -> Octree e -gmap testAABB f o = let (o', outliers) = gmap' testAABB f o in insertl testAABB o' outliers - - -gmap' :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> Octree e -> (Octree e, [e]) - -gmap' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers) - where - ents' = f <$> ents <*> ents - ents_kept = filter (keep testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - -gmap' testAABB f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - (Octree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) - where - ents' = (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 - ents_kept = filter (keep testAABB root) ents' - outliers = filter (not . keep testAABB root) ents' - (c1', out1) = gmap' testAABB f c1 - (c2', out2) = gmap' testAABB f c2 - (c3', out3) = gmap' testAABB f c3 - (c4', out4) = gmap' testAABB f c4 - (c5', out5) = gmap' testAABB f c5 - (c6', out6) = gmap' testAABB f c6 - (c7', out7) = gmap' testAABB f c7 - (c8', out8) = gmap' testAABB f c8 - - -population :: Octree e -> Int -population = F.foldr (\_ acc -> acc+1) 0 - - - - -instance Functor Octree where - - fmap f (Leaf root ents) = Leaf root $ fmap f ents - - fmap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - Octree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8' - where - c1' = fmap f c1 - c2' = fmap f c2 - c3' = fmap f c3 - c4' = fmap f c4 - c5' = fmap f c5 - c6' = fmap f c6 - c7' = fmap f c7 - c8' = fmap f c8 - - - -instance F.Foldable Octree where - - foldMap f (Leaf root ents) = mconcat . fmap f $ ents - - foldMap f (Octree root ents c1 c2 c3 c4 c5 c6 c7 c8) = - mconcat (fmap f ents) `mappend` - c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend` - c5' `mappend` c6' `mappend` c7' `mappend` c8' - where - c1' = F.foldMap f c1 - c2' = F.foldMap f c2 - c3' = F.foldMap f c3 - c4' = F.foldMap f c4 - c5' = F.foldMap f c5 - c6' = F.foldMap f c6 - c7' = F.foldMap f c7 - c8' = F.foldMap f c8 diff --git a/Spear/Math/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 @@ +module Spear.Math.QuadTree +( + QuadTree +, makeQuadTree +, clone +, Spear.Math.QuadTree.insert +, Spear.Math.QuadTree.map +, gmap +) +where + +import Spear.Collision.Types +import Spear.Math.AABB +import Spear.Math.Vector2 + +import Control.Applicative ((<*>)) +import Data.List +import Data.Functor +import Data.Monoid +import qualified Data.Foldable as F + + +-- | Represents an QuadTree. +data QuadTree e + = QuadTree + { root :: !AABB + , ents :: ![e] + , c1 :: !(QuadTree e) + , c2 :: !(QuadTree e) + , c3 :: !(QuadTree e) + , c4 :: !(QuadTree e) + , c5 :: !(QuadTree e) + , c6 :: !(QuadTree e) + , c7 :: !(QuadTree e) + , c8 :: !(QuadTree e) + } + | + Leaf + { root :: !AABB + , ents :: ![e] + } + + +-- | Builds an QuadTree using the specified AABB as the root and having the specified depth. +makeQuadTree :: Int -> AABB -> QuadTree e +makeQuadTree d root@(AABB min max) + | d == 0 = Leaf root [] + | otherwise = QuadTree root [] c1 c2 c3 c4 c5 c6 c7 c8 + where + boxes = subdivide root + c1 = makeQuadTree (d-1) $ boxes !! 0 + c2 = makeQuadTree (d-1) $ boxes !! 1 + c3 = makeQuadTree (d-1) $ boxes !! 2 + c4 = makeQuadTree (d-1) $ boxes !! 3 + c5 = makeQuadTree (d-1) $ boxes !! 4 + c6 = makeQuadTree (d-1) $ boxes !! 5 + c7 = makeQuadTree (d-1) $ boxes !! 6 + c8 = makeQuadTree (d-1) $ boxes !! 7 + + +subdivide :: AABB -> [AABB] +subdivide (AABB min max) = [a1, a2, a3, a4, a5, a6, a7, a8] + where + v = (max-min) / 2 + c = vec2 (x min + x v) (y min + y v) + a1 = AABB min c + a2 = AABB ( vec2 (x min) (y min)) ( vec2 (x c) (y c) ) + a3 = AABB ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) + a4 = AABB ( vec2 (x min) (y c) ) ( vec2 (x c) (y max)) + a5 = AABB ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) + a6 = AABB ( vec2 (x c) (y min)) ( vec2 (x max) (y c) ) + a7 = AABB ( vec2 (x c) (y c) ) ( vec2 (x max) (y max)) + a8 = AABB c max + + +-- | Clones the structure of an octree. The new octree has no entities. +clone :: QuadTree e -> QuadTree e +clone (Leaf root ents) = Leaf root [] +clone (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = QuadTree root [] c1' c2' c3' c4' c5' c6' c7' c8' + where + c1' = clone c1 + c2' = clone c2 + c3' = clone c3 + c4' = clone c4 + c5' = clone c5 + c6' = clone c6 + c7' = clone c7 + c8' = clone c8 + + +keep :: (e -> AABB -> CollisionType) -> AABB -> e -> Bool +keep testAABB aabb e = test == FullyContainedBy + where test = e `testAABB` aabb + + +-- | Inserts a list of entities into the given octree. +insert :: (e -> AABB -> CollisionType) -> QuadTree e -> [e] -> QuadTree e +insert testAABB octree es = octree' where (octree', _) = insert' testAABB es octree + + +insert' :: (e -> AABB -> CollisionType) -> [e] -> QuadTree e -> (QuadTree e, [e]) + +insert' testAABB es (Leaf root ents) = (Leaf root ents', outliers) + where + ents' = ents ++ ents_kept + ents_kept = filter (keep testAABB root) es + outliers = filter (not . keep testAABB root) es + +insert' testAABB es (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + (QuadTree root ents' c1' c2' c3' c4' c5' c6' c7' c8', outliers) + where + ents' = ents ++ ents_kept + new_ents = es ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 + ents_kept = filter (keep testAABB root) new_ents + outliers = filter (not . keep testAABB root) new_ents + (c1', ents1) = insert' testAABB es c1 + (c2', ents2) = insert' testAABB es c2 + (c3', ents3) = insert' testAABB es c3 + (c4', ents4) = insert' testAABB es c4 + (c5', ents5) = insert' testAABB es c5 + (c6', ents6) = insert' testAABB es c6 + (c7', ents7) = insert' testAABB es c7 + (c8', ents8) = insert' testAABB es c8 + + +-- | Extracts all entities from an octree. The resulting octree has no entities. +extract :: QuadTree e -> (QuadTree e, [e]) +extract (Leaf root ents) = (Leaf root [], ents) +extract (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = (QuadTree root [] c1' c2' c3' c4' c5' c6' c7' c8', ents') + where + (c1', ents1) = extract c1 + (c2', ents2) = extract c2 + (c3', ents3) = extract c3 + (c4', ents4) = extract c4 + (c5', ents5) = extract c5 + (c6', ents6) = extract c6 + (c7', ents7) = extract c7 + (c8', ents8) = extract c8 + ents' = ents ++ ents1 ++ ents2 ++ ents3 ++ ents4 ++ ents5 ++ ents6 ++ ents7 ++ ents8 + + +-- | Applies the given function to the entities in the octree. +-- Entities that break out of their cell are reallocated appropriately. +map :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> QuadTree e +map testAABB f o = + let (o', outliers) = map' testAABB f o + in Spear.Math.QuadTree.insert testAABB o' outliers + + +map' :: (e -> AABB -> CollisionType) -> (e -> e) -> QuadTree e -> (QuadTree e, [e]) + + +map' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers) + where + ents' = fmap f ents + ents_kept = filter (keep testAABB root) ents' + outliers = filter (not . keep testAABB root) ents' + + +map' testAABB f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + (QuadTree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) + where + ents' = (fmap f ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 + ents_kept = filter (keep testAABB root) ents' + outliers = filter (not . keep testAABB root) ents' + (c1', out1) = map' testAABB f c1 + (c2', out2) = map' testAABB f c2 + (c3', out3) = map' testAABB f c3 + (c4', out4) = map' testAABB f c4 + (c5', out5) = map' testAABB f c5 + (c6', out6) = map' testAABB f c6 + (c7', out7) = map' testAABB f c7 + (c8', out8) = map' testAABB f c8 + + +-- | Applies a function to the entity groups in the octree. +-- Entities that break out of their cell are reallocated appropriately. +gmap :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> QuadTree e +gmap testAABB f o = + let (o', outliers) = gmap' testAABB f o + in Spear.Math.QuadTree.insert testAABB o' outliers + + +gmap' :: (e -> AABB -> CollisionType) -> (e -> e -> e) -> QuadTree e -> (QuadTree e, [e]) + +gmap' testAABB f (Leaf root ents) = (Leaf root ents_kept, outliers) + where + ents' = f <$> ents <*> ents + ents_kept = filter (keep testAABB root) ents' + outliers = filter (not . keep testAABB root) ents' + +gmap' testAABB f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + (QuadTree root ents_kept c1' c2' c3' c4' c5' c6' c7' c8', outliers) + where + ents' = (f <$> ents <*> ents) ++ out1 ++ out2 ++ out3 ++ out4 ++ out5 ++ out6 ++ out7 ++ out8 + ents_kept = filter (keep testAABB root) ents' + outliers = filter (not . keep testAABB root) ents' + (c1', out1) = gmap' testAABB f c1 + (c2', out2) = gmap' testAABB f c2 + (c3', out3) = gmap' testAABB f c3 + (c4', out4) = gmap' testAABB f c4 + (c5', out5) = gmap' testAABB f c5 + (c6', out6) = gmap' testAABB f c6 + (c7', out7) = gmap' testAABB f c7 + (c8', out8) = gmap' testAABB f c8 + + +population :: QuadTree e -> Int +population = F.foldr (\_ acc -> acc+1) 0 + + + + +instance Functor QuadTree where + + fmap f (Leaf root ents) = Leaf root $ fmap f ents + + fmap f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + QuadTree root (fmap f ents) c1' c2' c3' c4' c5' c6' c7' c8' + where + c1' = fmap f c1 + c2' = fmap f c2 + c3' = fmap f c3 + c4' = fmap f c4 + c5' = fmap f c5 + c6' = fmap f c6 + c7' = fmap f c7 + c8' = fmap f c8 + + + +instance F.Foldable QuadTree where + + foldMap f (Leaf root ents) = mconcat . fmap f $ ents + + foldMap f (QuadTree root ents c1 c2 c3 c4 c5 c6 c7 c8) = + mconcat (fmap f ents) `mappend` + c1' `mappend` c2' `mappend` c3' `mappend` c4' `mappend` + c5' `mappend` c6' `mappend` c7' `mappend` c8' + where + c1' = F.foldMap f c1 + c2' = F.foldMap f c2 + c3' = F.foldMap f c3 + c4' = F.foldMap f c4 + c5' = F.foldMap f c5 + c6' = F.foldMap f c6 + c7' = F.foldMap f c7 + c8' = F.foldMap f c8 diff --git a/Spear/Math/Sphere.hs b/Spear/Math/Sphere.hs deleted file mode 100644 index 4a9e3fc..0000000 --- a/Spear/Math/Sphere.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Spear.Math.Sphere -( - Sphere(..) -, sphere -, spherept -) -where - - -import Spear.Math.Vector3 as Vector - - --- | A bounding volume. -data Sphere = Sphere - { center :: {-# UNPACK #-} !Vector3 - , radius :: {-# UNPACK #-} !Float - } - - --- | Create a 'Sphere' from the given points. -sphere :: [Vector3] -> Sphere - -sphere [] = error "Attempting to build a BoundingVolume from an empty list!" - -sphere (x:xs) = Sphere c r - where - c = min + (max-min)/2 - r = norm $ max - c - (min,max) = foldr update (x,x) xs - update p (min,max) = (Vector.min p min, Vector.max p max) - - --- | Return 'True' if the given 'Sphere' contains the given point, 'False' otherwise. -spherept :: Sphere -> Vector3 -> Bool -(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 @@ module Spear.Scene.Scene +where + +{-module Spear.Scene.Scene ( -- * Data types Scene @@ -150,3 +153,4 @@ collide' col scene@ListScene {} = render :: (obj -> Game s ()) -> Scene obj -> Game s () render rend (scene@ListScene {}) = Prelude.mapM_ rend $ objects scene render rend (scene@OctreeScene {}) = F.mapM_ rend $ world scene +-} \ No newline at end of file -- cgit v1.2.3