126 lines
4.6 KiB
Haskell
126 lines
4.6 KiB
Haskell
{- | Deals with moving creature wall collisions. -}
|
|
module Dodge.WallCreatureCollisions
|
|
( colCrsWalls
|
|
, colCrWall
|
|
, pushCreatureOutFromWalls
|
|
, crOnWall
|
|
) where
|
|
import Dodge.Data
|
|
--import Dodge.Data.DamageType
|
|
--import Dodge.Creature.State.Data
|
|
import Dodge.Zone
|
|
import Dodge.Base
|
|
import Geometry
|
|
|
|
import Data.Monoid
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import Control.Lens
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
colCrsWalls :: World -> World
|
|
colCrsWalls w = w & creatures %~ fmap (colCrWall w)
|
|
|
|
colCrWall :: World -> Creature -> Creature
|
|
colCrWall w c
|
|
| noclipIsOn && _crID c == 0 = c -- for noclip
|
|
| p1 == p2 = pushOrCrush ls c
|
|
-- | _crPos c' == _crPos c'' = c'
|
|
-- | otherwise = c & crPos .~ _crOldPos c
|
|
| otherwise = c'
|
|
where
|
|
-- c'' = c' & crPos %~ pushOutFromWalls rad ls
|
|
--c' = c & crPos %~ pushOutFromWalls' rad (reverse ls)
|
|
c' = c & crPos %~ pushOutFromCorners rad ls
|
|
. pushOutFromWalls rad ls
|
|
. flip (collidePointWalls p1) wls -- check push throughs
|
|
rad = _crRad c + wallBuffer
|
|
p1 = _crOldPos c
|
|
p2 = _crPos c
|
|
ls = IM.elems $ _wlLine <$> wls
|
|
wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w
|
|
--wallPoints = map fst ls
|
|
noclipIsOn = _debug_noclip $ _config w
|
|
|
|
-- 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 %~ pushOutFromWalls (_crRad cr) 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 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall rad p2)) wls
|
|
-- 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
|
|
|
|
pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature
|
|
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
|
|
[] -> cr
|
|
(p:_) -> cr & crPos .~ p
|
|
-- (_:p:_) -> cr
|
|
-- & crPos .~ p
|
|
-- & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
|
|
where
|
|
cpos = _crPos cr
|
|
|
|
-- note the inclusion of endpoints in circOnSeg
|
|
crOnWall :: Creature -> World -> Bool
|
|
crOnWall cr w = any (\(a,b) -> circOnSeg a b p r) wls
|
|
where
|
|
p = _crPos cr
|
|
r = _crRad cr
|
|
wls = fmap _wlLine . IM.filter (not . _wlWalkable) $ wallsNearPoint p w
|
|
|
|
-- 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
|
|
norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
|
|
wp1' = wp1 +.+ rad *.* norm
|
|
wp2' = wp2 +.+ rad *.* norm
|
|
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
|
|
isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
|
|
--pushOutFromWall' :: Float -> Point2 -> (Point2,Point2) -> Maybe Point2
|
|
--pushOutFromWall' rad cp2 (wp1,wp2)
|
|
-- | isOnWall = Just newP
|
|
-- | otherwise = Nothing
|
|
-- where
|
|
-- norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
|
|
-- wp1' = wp1 +.+ rad *.* norm
|
|
-- wp2' = wp2 +.+ rad *.* norm
|
|
-- newP = errorClosestPointOnLine 5 wp1' wp2' cp2
|
|
-- --isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
|
|
-- isOnWall = circOnSeg wp1 wp2 cp2 rad
|
|
|
|
pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2
|
|
pushOutFromCorners r ls p = foldr (intersectCirclePoint r . fst) p ls
|
|
|
|
--pushOutFromCorners' :: World -> Creature -> Creature
|
|
--pushOutFromCorners' w cr = cr & crPos .~ newPos
|
|
-- where
|
|
-- newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
|
|
-- ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w
|
|
|
|
--collideCorners :: Float -> [Point2] -> Point2 -> Point2
|
|
--collideCorners rad 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))
|