justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Improve door crushing

Browse Source
This commit is contained in:
justin
2026-03-26 19:21:10 +00:00
parent 31d7a00ecf
commit 01b765300e
10 changed files with 107 additions and 87 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+6 -2
View File
@@ -34,6 +34,7 @@ module Dodge.Base.Collide (
collide3,
) where
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.Monad
import qualified Data.IntSet as IS
@@ -48,7 +49,7 @@ import FoldableHelp
import Geometry
import Linear
collidePoint :: Point2 -> Point2 -> [Wall] -> (Point2, Maybe Wall)
collidePoint :: Foldable t => Point2 -> Point2 -> t Wall -> (Point2, Maybe Wall)
{-# INLINE collidePoint #-}
collidePoint sp ep = foldl' f (ep, Nothing)
where
@@ -201,7 +202,7 @@ collidePointTestFilter t sp ep =
collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
{-# INLINE collidePointWallsFilter #-}
collidePointWallsFilter t sp ep = collidePoint sp ep . filter t . wlsNearSeg sp ep
collidePointWallsFilter t sp ep = collidePoint sp ep . IM.filter t . wlsNearSeg sp ep
-- overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
-- -> StreamOf (Point2,Wall)
@@ -219,6 +220,7 @@ visibleWalls sp ep =
takeUntil (wlIsOpaque . snd)
. sortOn (dist sp . fst)
. overlapSegWalls sp ep
. IM.elems
. wlsNearSeg sp ep
allVisibleWalls :: World -> [(Point2, Wall)]
@@ -296,6 +298,7 @@ hasLOS :: Point2 -> Point2 -> World -> Bool
hasLOS p1 p2 =
not
. collidePointTestFilter (const True) p1 p2
. IM.elems
. wlsNearSeg p1 p2
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
@@ -312,6 +315,7 @@ hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
hasLOSIndirect p1 p2 =
not
. collidePointTestFilter wlIsOpaque p1 p2
. IM.elems
. wlsNearSeg p1 p2
canSee :: Int -> Int -> World -> Bool
src/Dodge/Creature/Action/Blink.hs
+2 -1
View File
@@ -5,6 +5,7 @@ module Dodge.Creature.Action.Blink (
unsafeBlinkAction,
) where
import qualified Data.IntMap.Strict as IM
import Linear
import Dodge.Creature.Radius
import Dodge.Zoning.Wall
@@ -34,7 +35,7 @@ blinkActionMousePos cr w =
p1 = w ^. cWorld . lWorld . lAimPos
cpos = cr ^. crPos . _xy
--p2 = bouncePoint (const True) 1 cpos p1 w
p2 = pushIntoMaybe $ collideCircWalls cpos p1 r (wlsNearSeg cpos p1 w)
p2 = pushIntoMaybe $ collideCircWalls cpos p1 r (IM.elems $ wlsNearSeg cpos p1 w)
r = crRad $ cr ^. crType
p3 = maybe p1 ((+.+ squashNormalizeV (cpos -.- p1)) . fst) p2
--p3 = maybe p1 (const 0) p2
src/Dodge/Debug/Picture.hs
+1 -1
View File
@@ -276,7 +276,7 @@ drawFarWallDetect w =
( \q ->
line
[ p
, fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
, fst $ collidePoint p q $ filter wlIsOpaque $ IM.elems $ wlsNearSeg p q w
]
)
$ getViewpoints p (_cWorld w)
src/Dodge/TestString.hs
+1 -2
View File
@@ -33,8 +33,7 @@ import Data.Monoid
import RandomHelp
testStringInit :: Universe -> [String]
testStringInit _ = []
--(fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crHP . _HP)
testStringInit u = (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crWallTouch)
-- <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
--testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
--testStringInit u = map show
src/Dodge/Update.hs
+1 -1
View File
@@ -352,7 +352,7 @@ muzzleWallCheck w cr = fromMaybe cr $ do
cp = cr ^. crPos . _xy
-- cop = cr ^. crOldPos . _xy
r <- boundPointsRect (cp : ps)
let wls = uncurry wlsNearRect r w & filter (not . _wlTouchThrough)
let wls = uncurry wlsNearRect r w & IM.elems & filter (not . _wlTouchThrough)
vs = mapMaybe (g cp wls) ps
return $ if null vs
then cr
src/Dodge/Update/Camera.hs
+3 -2
View File
@@ -26,6 +26,7 @@ import Geometry
import LensHelp
import SDL (MouseButton (..))
import qualified SDL
import qualified Data.IntMap.Strict as IM
{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
update where your avatar's view is from. -}
@@ -220,7 +221,7 @@ rotateToOverlappingWall w =
maybe
id
(doWallRotate . snd)
(overlapCircWallsClosest p r (filter _wlRotateTo $ wlsNearCirc p r w))
(overlapCircWallsClosest p r (filter _wlRotateTo . IM.elems $ wlsNearCirc p r w))
w
where
r = crRad (cr ^. crType) + 10
@@ -245,7 +246,7 @@ farWallDistDirection :: Point2 -> World -> Maybe (Float, Float, Float, Float)
farWallDistDirection p w = boundPoints $ map f $ getViewpoints p (_cWorld w)
where
f q = (rotateV (negate (w ^. wCam . camRot)) . (-.- p)) (foldl' findPoint q (wls q))
wls q = filter wlIsOpaque $ wlsNearSeg p q w
wls q = filter wlIsOpaque . IM.elems $ wlsNearSeg p q w
findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
findBoundDists :: Config -> World -> (Float, Float, Float, Float)
src/Dodge/WallCreatureCollisions.hs
+18 -4
View File
@@ -1,6 +1,7 @@
-- | Deals with moving creature wall collisions.
module Dodge.WallCreatureCollisions (colCrsWalls) where
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Data.Foldable
import qualified Data.IntSet as IS
@@ -28,19 +29,23 @@ colCrWall w c = cornpush . wallpush $ pushthrough c
r = crRad (c ^. crType) + wallBuffer
p1 = c ^. crOldPos . _xy
p2 = c ^. crPos . _xy
ls = _wlLine <$> wls
ls = _wlLine <$> IM.elems wls
ls' = filter (uncurry $ isLHS p1) ls
wls = filter notff $ wlsNearCirc p2 r w
wls = IM.filter notff $ wlsNearCirc p2 (2*r) w
notff x = x ^. wlMaterial /= ForceField
pushCr :: [Wall] -> Creature -> Creature
-- might want to check angled crushing
pushCr :: IM.IntMap Wall -> Creature -> Creature
pushCr wls cr
| dist ep sp > r && dist ep ap > r =
| (dist ep sp > r && dist ep ap > r)
|| wlsCrush twls
=
ecr
& crDamage <>~ [Crushing 1000 0]
& crPos . _xy .~ ap
| otherwise = ecr
where
twls = IM.elems $ IM.restrictKeys wls (ecr ^. crWallTouch)
ep = ecr ^. crPos . _xy
ap = cr ^. crOldPos . _xy
sp = cr ^. crPos . _xy
@@ -50,6 +55,15 @@ pushCr wls cr
Just p -> acr & crPos . _xy .~ p & crWallTouch %~ IS.insert (wl ^. wlID)
Nothing -> acr
wlsCrush :: [Wall] -> Bool
wlsCrush [] = False
wlsCrush (x:xs) = any (wlWlCrush x) xs || wlsCrush xs
wlWlCrush :: Wall -> Wall -> Bool
wlWlCrush w1 w2 = angleVV (f w1) (f w2) > 0.75 * pi
where
f = uncurry (-) . (^. wlLine)
-- the amount to push creatures out from walls, extra to their radius
wallBuffer :: Float
wallBuffer = 0
src/Dodge/WorldEvent/ThingsHit.hs
+2 -2
View File
@@ -163,10 +163,10 @@ wlHitPos sp ep = maybe ep ((+ normalize (ep - sp)) . fst) . safeHead . wlsHit sp
wlsHitUnsorted :: Point2 -> Point2 -> World -> [(Point2, Wall)]
wlsHitUnsorted sp ep
| sp == ep = const mempty
| otherwise = overlapSegWalls sp ep . wlsNearSeg sp ep
| otherwise = overlapSegWalls sp ep . IM.elems . wlsNearSeg sp ep
wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
wlsHitRadial p r = mapMaybe f . wlsNearCirc p r
wlsHitRadial p r = mapMaybe f . IM.elems . wlsNearCirc p r
where
--f wl = uncurry (intersectSegSeg p (p - r *.* v)) (_wlLine wl) <&> (,wl)
f wl = mhp <&> (,wl)
src/Dodge/Zoning/Wall.hs
+6 -7
View File
@@ -11,7 +11,6 @@ module Dodge.Zoning.Wall
import Control.Lens
import qualified Data.IntSet as IS
import Data.Maybe
import Dodge.Data.World
import Dodge.Zoning.Base
import FoldableHelp
@@ -32,21 +31,21 @@ wlIXsNearRect = nearRect wlZoneSize _wlZoning
wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)
wlsFromIXs :: World -> IS.IntSet -> [Wall]
wlsFromIXs :: World -> IS.IntSet -> IM.IntMap Wall
{-# INLINE wlsFromIXs #-}
wlsFromIXs w = mapMaybe (\wlid -> w ^? cWorld . lWorld . walls . ix wlid) . IS.toList
wlsFromIXs w = IM.restrictKeys (w ^. cWorld . lWorld . walls)
wlsNearPoint :: Point2 -> World -> [Wall]
wlsNearPoint :: Point2 -> World -> IM.IntMap Wall
wlsNearPoint p w = wlsFromIXs w $ wlIXsNearPoint p w
wlsNearSeg :: Point2 -> Point2 -> World -> [Wall]
wlsNearSeg :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wlsNearSeg #-}
wlsNearSeg sp ep w = wlsFromIXs w $ wlIXsNearSeg sp ep w
wlsNearRect :: Point2 -> Point2 -> World -> [Wall]
wlsNearRect :: Point2 -> Point2 -> World -> IM.IntMap Wall
wlsNearRect sp ep w = wlsFromIXs w $ wlIXsNearRect sp ep w
wlsNearCirc :: Point2 -> Float -> World -> [Wall]
wlsNearCirc :: Point2 -> Float -> World -> IM.IntMap Wall
wlsNearCirc p r w = wlsFromIXs w $ wlIXsNearCirc p r w
wlZoneSize :: Float