122 lines
4.2 KiB
Haskell
122 lines
4.2 KiB
Haskell
-- | Deals with moving creature wall collisions.
|
|
module Dodge.WallCreatureCollisions (
|
|
colCrsWalls,
|
|
colCrWall,
|
|
pushCreatureOutFromWalls,
|
|
crOnWall,
|
|
) where
|
|
|
|
import qualified Data.IntSet as IS
|
|
import Data.Foldable
|
|
import Linear
|
|
import Dodge.Creature.Radius
|
|
import Control.Lens
|
|
import Data.Monoid
|
|
import Dodge.Base
|
|
import Dodge.Data.Universe
|
|
import Dodge.Zoning.Wall
|
|
import Geometry
|
|
|
|
colCrsWalls :: Universe -> Universe
|
|
colCrsWalls uv = uv & uvWorld . cWorld . lWorld . creatures %~ fmap (noclipCheck (_uvConfig uv) (_uvWorld uv))
|
|
|
|
noclipCheck :: Config -> World -> Creature -> Creature
|
|
noclipCheck cfig w c
|
|
| debugOn Noclip cfig && _crID c == 0 = c -- for noclip
|
|
| otherwise = colCrWall w c
|
|
|
|
colCrWall :: World -> Creature -> Creature
|
|
colCrWall w c = cornpush . wallpush $ pushthrough c
|
|
where
|
|
cornpush = crPos . _xy %~ pushOutFromCorners r ls'
|
|
wallpush = pushCr' wls
|
|
pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
|
|
r = crRad (c ^. crType) + wallBuffer
|
|
p1 = c ^. crOldPos . _xy
|
|
p2 = c ^. crPos . _xy
|
|
ls = _wlLine <$> wls
|
|
ls' = filter (uncurry $ isLHS p1) ls
|
|
wls = filter notff $ wlsNearCirc p2 r w
|
|
notff x = x ^. wlMaterial /= ForceField
|
|
|
|
pushCr' :: [Wall] -> Creature -> Creature
|
|
pushCr' wls cr
|
|
| dist ep sp > r
|
|
&& dist ep ap > r = ecr & crDamage <>~ [Crushing 1000 0]
|
|
& crPos . _xy .~ ap
|
|
| otherwise = ecr
|
|
where
|
|
ep = ecr ^. crPos . _xy
|
|
ap = cr ^. crOldPos . _xy
|
|
sp = cr ^. crPos . _xy
|
|
ecr = foldl' f (cr & crWallTouch .~ mempty) wls
|
|
r = crRad (cr ^. crType)
|
|
f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
|
|
Just p -> acr & crPos . _xy .~ p & crWallTouch %~ IS.insert (wl ^. wlID)
|
|
Nothing -> acr
|
|
|
|
-- the amount to push creatures out from walls, extra to their radius
|
|
wallBuffer :: Float
|
|
wallBuffer = 0
|
|
|
|
pushCreatureOutFromWalls :: [(Point2, Point2)] -> Creature -> Creature
|
|
pushCreatureOutFromWalls ls cr = cr & crPos . _xy
|
|
%~ pushOutFromWalls (crRad (cr ^. crType)) ls
|
|
|
|
-- 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
|
|
pushOutFromWalls :: Float -> [(Point2, Point2)] -> Point2 -> Point2
|
|
pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of
|
|
Nothing -> p1
|
|
Just p2 -> pushOutFromWalls rad (tail wls) p2
|
|
|
|
--wallPushList :: Float -> [Wall] -> Point2 -> [(Point2, Wall)]
|
|
--wallPushList rad wls p1 = mapMaybe f wls
|
|
-- where
|
|
-- f :: Wall -> Maybe (Point2,Wall)
|
|
-- f wl = case pushOutFromWall rad p1 (wl ^. wlLine) of
|
|
-- Nothing -> Nothing
|
|
-- Just p -> Just (p,wl)
|
|
|
|
-- possible improvement: choose between the closer of p2 and "p3" to p1
|
|
|
|
--pushOutFromWalls' :: Float -> [(Point2,Point2)] -> Point2 -> Point2
|
|
--pushOutFromWalls' rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall' rad p1)) wls of
|
|
-- Nothing -> p1
|
|
-- Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall' rad p2)) wls
|
|
-- -- possible improvement: choose between the closer of p2 and "p3" to p1
|
|
|
|
-- note the inclusion of endpoints in circOnSeg
|
|
crOnWall :: Creature -> World -> Bool
|
|
crOnWall cr =
|
|
any (uncurry (circOnSeg p r) . _wlLine)
|
|
. filter notff
|
|
. wlsNearCirc p r
|
|
where
|
|
notff x = x ^. wlMaterial /= ForceField
|
|
p = cr ^. crPos . _xy
|
|
r = crRad (cr ^. crType)
|
|
|
|
-- assumes that the wall is orientated
|
|
-- assumes wall points are different
|
|
pushOutFromWall :: Float -> Point2 -> (Point2, Point2) -> Maybe Point2
|
|
pushOutFromWall rad cp2 (wp1, wp2)
|
|
| isOnWall = Just newP
|
|
| otherwise = Nothing
|
|
where
|
|
n = errorNormalizeV 61 $ vNormal (wp1 - wp2)
|
|
wp1' = wp1 + rad *^ n
|
|
wp2' = wp2 + rad *^ n
|
|
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
|
|
isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
|
|
|
|
pushOutFromCorners :: Float -> [(Point2, Point2)] -> Point2 -> Point2
|
|
--pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls
|
|
pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst)
|
|
|
|
squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
|
|
squashIntersectCirclePoint rad p cCen
|
|
| dist cCen p > rad = cCen
|
|
| otherwise = p + (rad *^ squashNormalizeV (cCen - p))
|