From 9f4ff3a75a4af8094db31298e3c3e81445c6bab3 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 19 Nov 2021 23:22:49 +0000 Subject: [PATCH] Better check for wall collisions when expanding creature --- src/Dodge/Base.hs | 3 +- src/Dodge/Creature/Action.hs | 9 +++--- src/Dodge/Item/Weapon/Utility.hs | 2 +- src/Dodge/WallCreatureCollisions.hs | 43 +++++++++++++++++------------ 4 files changed, 34 insertions(+), 23 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 1047b92da..a5816bbd8 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -367,7 +367,8 @@ collidePointCrsWithoutPoint cid p1 p2 w $ _creatures w where f (cID,(p,_)) = (p,cID) -{- | Test if a circle collides with any wall. -} +{- | Test if a circle collides with any wall. + - Note no check on whether the wall is walkable. -} circOnSomeWall :: Point2 -> Float -> World -> Bool circOnSomeWall p rad w = any (\(x,y) -> circOnSeg x y p rad) diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index cdc8af41f..384fac9e3 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -8,7 +8,7 @@ module Dodge.Creature.Action , dropUnselected , startReloadingWeapon , blinkAction - , maybeSizeSelf + , sizeSelf , crAutoReload , copyInvItemToFloor , youDropItem @@ -295,9 +295,10 @@ pickUpItem cid flit w = case maybeInvSlot of Nothing -> w' Just j -> w' & itemPositions . ix j .~ InInv 0 invid -maybeSizeSelf :: Float -> Creature -> World -> Maybe World -maybeSizeSelf x cr w - | _crPos cr1 == _crPos cr2 = Just $ w +sizeSelf :: Float -> Creature -> World -> Maybe World +sizeSelf x cr w + -- | _crPos cr1 == _crPos cr2 = Just $ w + | not (crOnWall cr1 w) = Just $ w & soundMultiFrom [TeleSound 0,TeleSound 1] cpos teleS Nothing & over distortions (distortionBulge :) & creatures . ix cid %~ diff --git a/src/Dodge/Item/Weapon/Utility.hs b/src/Dodge/Item/Weapon/Utility.hs index 07cca75a8..294c8d494 100644 --- a/src/Dodge/Item/Weapon/Utility.hs +++ b/src/Dodge/Item/Weapon/Utility.hs @@ -47,7 +47,7 @@ useShrinkGun it cr w = if _itBool $ _itAttachment it then tryResize 0.5 $ stripNoItems cr . f False UndroppableIdentified . dropUnselected cr else tryResize 1 $ f True Uncursed . setMinInvSize defaultInvSize cr where - tryResize x g = maybe w g $ maybeSizeSelf x cr w + tryResize x g = maybe w g $ sizeSelf x cr w f isInUse cstatus = creatures . ix (_crID cr) . crInv . ix (_crInvSel cr) %~ ( (itAttachment . itBool .~ isInUse) . (itCurseStatus .~ cstatus) ) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 7f7ef32e4..b0952c747 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -3,6 +3,7 @@ module Dodge.WallCreatureCollisions ( colCrsWalls , colCrWall , pushCreatureOutFromWalls + , crOnWall ) where import Dodge.Data --import Dodge.Data.DamageType @@ -30,7 +31,7 @@ colCrWall w c where -- c'' = c' & crPos %~ pushOutFromWalls rad ls --c' = c & crPos %~ pushOutFromWalls' rad (reverse ls) - c' = c & crPos %~ pushOutFromCorners rad (reverse ls) + c' = c & crPos %~ pushOutFromCorners rad ls . pushOutFromWalls rad ls . flip (collidePointWalls p1) wls -- check push throughs rad = _crRad c + wallBuffer @@ -57,11 +58,11 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall 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 +--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 @@ -73,6 +74,14 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of 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 @@ -85,17 +94,17 @@ pushOutFromWall rad cp2 (wp1,wp2) 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 +--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) p (map fst ls)