113 lines
4.3 KiB
Haskell
113 lines
4.3 KiB
Haskell
module Dodge.WallCreatureCollisions where
|
|
-- imports {{{
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Geometry
|
|
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import Control.Lens
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
colCrsWalls :: World -> World
|
|
colCrsWalls w = over creatures (fmap (colCrWall w)) w
|
|
|
|
colCrWall :: World -> Creature -> Creature
|
|
colCrWall w c
|
|
| p1 == p2 = pushOrCrush ls c
|
|
| otherwise = c & crPos %~
|
|
collideCorners rad p1 wallPoints
|
|
. collideWalls rad p1 ls
|
|
. checkPushThroughs rad p1 ls
|
|
where
|
|
rad = _crRad c + wallBuffer
|
|
p1 = _crOldPos c
|
|
p2 = _crPos c
|
|
ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
|
|
wallPoints = nub $ concat ls
|
|
|
|
-- colCrPushThrough :: World -> Creature -> Creature
|
|
-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
|
|
-- where rad = _crRad cr + wallBuffer
|
|
-- p1 = _crOldPos cr
|
|
-- p2 = _crPos cr
|
|
-- ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
|
|
-- -- probably best to push check pushing through walls before creature springs
|
|
|
|
-- the amount to push creatures out from walls, extra to their radius
|
|
wallBuffer = 3
|
|
|
|
-- the following tests whether or not a point is on a wall, and if so pushes it
|
|
-- out from the wall
|
|
-- this is then repeated if the point ends up on a new wall
|
|
collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
|
|
collideWalls rad cp1 walls cp2
|
|
= case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
|
|
Nothing -> cp2
|
|
Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
|
|
Nothing -> cp3
|
|
Just cp4 -> cp4
|
|
|
|
-- pushes a point out from a list of walls
|
|
-- if multiple new points occur, chooses the one closest to the orignal point
|
|
pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2
|
|
pushOutFromWalls rad walls p =
|
|
fromMaybe p
|
|
. listToMaybe
|
|
. sortBy (compare `on` dist p)
|
|
$ mapMaybe (pushOutFromWall rad p)
|
|
walls
|
|
|
|
pushOrCrush :: [[Point2]] -> Creature -> Creature
|
|
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
|
|
[] -> cr
|
|
[p] -> cr & crPos .~ p
|
|
_ -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :)
|
|
where
|
|
cpos = _crPos cr
|
|
|
|
-- assumes that the wall is orientated
|
|
-- assumes wall points are different
|
|
pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2)
|
|
pushOutFromWall rad cp2 (wp1:wp2:_)
|
|
| isOnWall = Just newP -- +.+ (1 *.* norm))
|
|
| otherwise = Nothing
|
|
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
|
|
wp1' = (rad *.* norm) +.+ wp1
|
|
wp2' = (rad *.* norm) +.+ wp2
|
|
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
|
|
isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
|
|
isJust Nothing = False
|
|
isJust _ = True
|
|
|
|
pushOutFromCorners :: World -> Creature -> Creature
|
|
pushOutFromCorners w cr = cr & crPos .~ newPos
|
|
where
|
|
newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
|
|
ls = nub . concat . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w
|
|
|
|
collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
|
|
collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps
|
|
|
|
-- collide circles with points (outer corners)
|
|
intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
|
|
intersectCirclePoint rad p cCen | dist cCen p > rad = cCen
|
|
| otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
|
|
|
|
checkPushThroughs :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
|
|
checkPushThroughs rad cp1 walls cp2
|
|
= fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls
|
|
|
|
checkPushThrough :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
|
|
checkPushThrough rad cp1 cp2 (wp1:wp2:_)
|
|
| isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
|
|
| otherwise = Nothing
|
|
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
|
|
wp1' = (rad *.* norm) +.+ wp1
|
|
wp2' = (rad *.* norm) +.+ wp2
|
|
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
|
|
isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
|
|
isJust Nothing = False
|
|
isJust _ = True
|