diff options
-rw-r--r-- | Spear/Collision.hs | 35 |
1 files changed, 26 insertions, 9 deletions
diff --git a/Spear/Collision.hs b/Spear/Collision.hs index 0dbebdb..31187c9 100644 --- a/Spear/Collision.hs +++ b/Spear/Collision.hs | |||
@@ -32,7 +32,9 @@ data CollisionType = NoCollision | Collision | FullyContains | FullyContainedBy | |||
32 | 32 | ||
33 | class Collisionable a where | 33 | class Collisionable a where |
34 | collideBox :: AABB -> a -> CollisionType | 34 | collideBox :: AABB -> a -> CollisionType |
35 | collideSphere :: Circle -> a -> CollisionType | 35 | collideCircle :: Circle -> a -> CollisionType |
36 | getBox :: a -> AABB | ||
37 | getCircle :: a -> Circle | ||
36 | 38 | ||
37 | 39 | ||
38 | instance Collisionable AABB where | 40 | instance Collisionable AABB where |
@@ -48,7 +50,7 @@ instance Collisionable AABB where | |||
48 | | (y min1) > (y max2) = NoCollision | 50 | | (y min1) > (y max2) = NoCollision |
49 | | otherwise = Collision | 51 | | otherwise = Collision |
50 | 52 | ||
51 | collideSphere sphere@(Circle c r) aabb@(AABB min max) | 53 | collideCircle sphere@(Circle c r) aabb@(AABB min max) |
52 | | test == FullyContains || test == FullyContainedBy = test | 54 | | test == FullyContains || test == FullyContainedBy = test |
53 | | normSq (c - boxC) > (l + r)^2 = NoCollision | 55 | | normSq (c - boxC) > (l + r)^2 = NoCollision |
54 | | otherwise = Collision | 56 | | otherwise = Collision |
@@ -57,16 +59,19 @@ instance Collisionable AABB where | |||
57 | boxC = min + (max-min)/2 | 59 | boxC = min + (max-min)/2 |
58 | l = norm $ min + (vec2 (x boxC) (y min)) - min | 60 | l = norm $ min + (vec2 (x boxC) (y min)) - min |
59 | 61 | ||
62 | getBox = id | ||
63 | |||
64 | getCircle = circleFromAABB | ||
60 | 65 | ||
61 | 66 | ||
62 | instance Collisionable Circle where | 67 | instance Collisionable Circle where |
63 | 68 | ||
64 | collideBox box sphere = case collideSphere sphere box of | 69 | collideBox box sphere = case collideCircle sphere box of |
65 | FullyContains -> FullyContainedBy | 70 | FullyContains -> FullyContainedBy |
66 | FullyContainedBy -> FullyContains | 71 | FullyContainedBy -> FullyContains |
67 | x -> x | 72 | x -> x |
68 | 73 | ||
69 | collideSphere s1@(Circle c1 r1) s2@(Circle c2 r2) | 74 | collideCircle s1@(Circle c1 r1) s2@(Circle c2 r2) |
70 | | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy | 75 | | distance_centers <= sub_radii = if (r1 > r2) then FullyContains else FullyContainedBy |
71 | | distance_centers <= sum_radii = Collision | 76 | | distance_centers <= sum_radii = Collision |
72 | | otherwise = NoCollision | 77 | | otherwise = NoCollision |
@@ -74,6 +79,10 @@ instance Collisionable Circle where | |||
74 | distance_centers = normSq $ c1 - c2 | 79 | distance_centers = normSq $ c1 - c2 |
75 | sum_radii = (r1 + r2)^2 | 80 | sum_radii = (r1 + r2)^2 |
76 | sub_radii = (r1 - r2)^2 | 81 | sub_radii = (r1 - r2)^2 |
82 | |||
83 | getBox = aabbFromCircle | ||
84 | |||
85 | getCircle = id | ||
77 | 86 | ||
78 | 87 | ||
79 | aabbPoints :: AABB -> [Vector2] | 88 | aabbPoints :: AABB -> [Vector2] |
@@ -92,9 +101,9 @@ aabbPoints (AABB min max) = [p1,p2,p3,p4,p5,p6,p7,p8] | |||
92 | -- | A collisioner component. | 101 | -- | A collisioner component. |
93 | data Collisioner | 102 | data Collisioner |
94 | -- | An axis-aligned bounding box. | 103 | -- | An axis-aligned bounding box. |
95 | = AABBCol { getBox :: {-# UNPACK #-} !AABB } | 104 | = AABBCol {-# UNPACK #-} !AABB |
96 | -- | A bounding sphere. | 105 | -- | A bounding sphere. |
97 | | CircleCol { getCircle :: {-# UNPACK #-} !Circle } | 106 | | CircleCol {-# UNPACK #-} !Circle |
98 | 107 | ||
99 | 108 | ||
100 | -- | Create a collisioner from the specified box. | 109 | -- | Create a collisioner from the specified box. |
@@ -142,9 +151,9 @@ generatePoints = foldr generate [] | |||
142 | -- | Collide the given collisioners. | 151 | -- | Collide the given collisioners. |
143 | collide :: Collisioner -> Collisioner -> CollisionType | 152 | collide :: Collisioner -> Collisioner -> CollisionType |
144 | collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2 | 153 | collide (AABBCol box1) (AABBCol box2) = collideBox box1 box2 |
145 | collide (CircleCol s1) (CircleCol s2) = collideSphere s1 s2 | 154 | collide (CircleCol s1) (CircleCol s2) = collideCircle s1 s2 |
146 | collide (AABBCol box) (CircleCol sphere) = collideBox box sphere | 155 | collide (AABBCol box) (CircleCol circle) = collideBox box circle |
147 | collide (CircleCol sphere) (AABBCol box) = collideSphere sphere box | 156 | collide (CircleCol circle) (AABBCol box) = collideCircle circle box |
148 | 157 | ||
149 | 158 | ||
150 | -- | Move the collisioner. | 159 | -- | Move the collisioner. |
@@ -159,3 +168,11 @@ aabbFromCircle (Circle c r) = AABB bot top | |||
159 | where | 168 | where |
160 | bot = c - (vec2 r r) | 169 | bot = c - (vec2 r r) |
161 | top = c + (vec2 r r) | 170 | top = c + (vec2 r r) |
171 | |||
172 | |||
173 | -- | Create the minimal circle fully containing the specified box. | ||
174 | circleFromAABB :: AABB -> Circle | ||
175 | circleFromAABB (AABB min max) = Circle c r | ||
176 | where | ||
177 | c = scale 0.5 (min + max) | ||
178 | r = norm . scale 0.5 $ max - min | ||