131 lines
5.0 KiB
Haskell
131 lines
5.0 KiB
Haskell
-- | Deals with moving creature wall collisions.
|
|
module Dodge.WallCreatureCollisions (colCrsWalls) where
|
|
|
|
--import Control.Applicative
|
|
--import Data.Monoid
|
|
import Dodge.Door.DoorLerp
|
|
import Dodge.ShiftPoint
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import Dodge.Base
|
|
import Dodge.Creature.Radius
|
|
import Dodge.Data.Universe
|
|
import Dodge.Zoning.Wall
|
|
import Geometry
|
|
import Linear
|
|
|
|
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 (w ^. cWorld . lWorld) wls
|
|
pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
|
|
r | SlimeCrit {} <- c ^. crType = min 10 . crRad $ c ^. crType
|
|
| otherwise = crRad $ c ^. crType
|
|
p1 = c ^. crOldPos . _xy
|
|
p2 = c ^. crPos . _xy
|
|
ls = _wlLine <$> IM.elems wls
|
|
ls' = filter (uncurry $ isLHS p1) ls
|
|
wls = IM.filter notff $ wlsNearCirc p2 (2*r) w
|
|
notff x = x ^. wlMaterial /= ForceField
|
|
|
|
-- might want to check angled crushing
|
|
pushCr :: LWorld -> IM.IntMap Wall -> Creature -> Creature
|
|
pushCr w wls cr
|
|
-- | (dist ep sp > r && dist ep ap > r)
|
|
-- || wlsCrush' w (cr ^. crPos . _xy) twls =
|
|
| wlsCrush' w (cr ^. crPos . _xy) twls =
|
|
ecr
|
|
& crDamage <>~ [Crushing 1000 0 UnassignedO]
|
|
& crPos . _xy .~ ap
|
|
-- | Just s <- wlsCrush w (cr ^. crPos . _xy) twls =
|
|
-- ecr
|
|
-- & crDamage <>~ [Crushing 1000 0]
|
|
-- & crPos . _xy .~ ap
|
|
-- & crName .~ s
|
|
| otherwise = ecr
|
|
where
|
|
-- stwls = IM.filter (\wl -> uncurry circOnSegNoEndpoints (wl ^. wlLine) sp r) wls
|
|
twls = IM.elems $ IM.intersection wls (ecr ^. crWallTouch) -- `IM.union` stwls
|
|
-- ep = ecr ^. crPos . _xy
|
|
ap = cr ^. crOldPos . _xy
|
|
-- sp = cr ^. crPos . _xy
|
|
ecr = foldl' f (cr & crWallTouch .~ mempty) wls
|
|
r | SlimeCrit {} <- cr ^. crType = min 10 . crRad $ cr ^. crType
|
|
| otherwise = crRad $ cr ^. crType
|
|
f acr wl = case pushOutFromWall' r (acr ^. crPos . _xy) (wl ^. wlLine) of
|
|
Just (p,hitp) -> acr & crPos . _xy .~ p & crWallTouch . at (wl ^. wlID) ?~ hitp
|
|
Nothing -> acr
|
|
|
|
wallMovement :: LWorld -> Point2 -> Wall -> Point2
|
|
wallMovement w p wl = fromMaybe 0 $ do
|
|
drid <- w ^? walls . ix (wl ^. wlID) . wlStructure . wsDoor
|
|
dr <- w ^? doors . ix drid
|
|
let oldp = shiftPointBy (doDoorLerp dr (dr ^. drOldLerp))
|
|
$ invShiftPointBy (doDoorLerp dr (dr ^. drLerp)) p
|
|
return $ p - oldp
|
|
|
|
--wlsCrush :: LWorld -> Point2 -> [Wall] -> Maybe String
|
|
--wlsCrush _ _ [] = Nothing
|
|
--wlsCrush w p (x:xs) = getFirst (foldMap (First . wlWlCrush w p x) xs) <|> wlsCrush w p xs
|
|
|
|
wlsCrush' :: LWorld -> Point2 -> [Wall] -> Bool
|
|
wlsCrush' _ _ [] = False
|
|
wlsCrush' w p (x:xs) = any (wlWlCrush' w p x) xs || wlsCrush' w p xs
|
|
|
|
--wlWlCrush :: LWorld -> Point2 -> Wall -> Wall -> Maybe String
|
|
--wlWlCrush w p w1 w2
|
|
-- | wlWlCrush' w p w1 w2 = Just $ show (w1 ^. wlID) <> ":" <> show (w2 ^. wlID)
|
|
-- | otherwise = Nothing
|
|
|
|
wlWlCrush' :: LWorld -> Point2 -> Wall -> Wall -> Bool
|
|
wlWlCrush' w p w1 w2 = (t w1 w2 || t w2 w1) -- test either wall is moving towards the other
|
|
&& norm (f w1 + f w2) < 0.2 -- test walls are facing each other
|
|
where
|
|
-- t wl = dotV (vNormal (normalizeV (uncurry (-) (wl ^. wlLine)))) (wallMovement w p wl) > 0
|
|
t x y = dotV (vNormal (normalizeV (uncurry (-) (x ^. wlLine))))
|
|
(wallMovement w p x - wallMovement w p y) > 0
|
|
f = normalizeV . uncurry (-) . (^. wlLine)
|
|
|
|
---- 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
|
|
|
|
pushOutFromWall' :: Float -> Point2 -> (Point2, Point2) -> Maybe (Point2,Point2)
|
|
pushOutFromWall' rad cp2 (wp1, wp2)
|
|
| isOnWall = Just (newP,newP - rad *^ n)
|
|
| 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 = 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))
|