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

Sometimes crush creatures when doors close on them

Browse Source
This commit is contained in:
justin
2026-03-26 12:39:54 +00:00
parent e01029d06d
commit 7999373b69
7 changed files with 249 additions and 156 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Creature.hs
+2
View File
@@ -30,6 +30,7 @@ import Dodge.Data.Creature.State
import Dodge.Data.Item
import Dodge.Data.Material
import Geometry.Data
import qualified Data.IntMap.Strict as IM
--import qualified IntMapHelp as IM
data Creature = Creature
@@ -57,6 +58,7 @@ data Creature = Creature
, _crIntention :: Intention
, _crName :: String
, _crDeathTimer :: Int
, _crCrushTimers :: IM.IntMap Int
}
data CrHP
src/Dodge/Debug.hs
+39 -1
View File
@@ -42,6 +42,45 @@ overDebugEvent u = fromMaybe u $ do
debugEvent :: DebugBool -> Universe -> Universe
debugEvent db u = u & uvDebug . at db .~ debugItem db u
& debugEvent' db
-- possibly don't want this running when the game is paused/not running normally
-- note this happens before functionalUpdate
debugEvent' :: DebugBool -> Universe -> Universe
debugEvent' = \case
Collision_test -> id
Circ_collision_test -> id
Show_walls_near_point_cursor -> id
Show_walls_near_segment -> id
Display_debug -> id
Noclip -> id
Remove_LOS -> id
Cull_more_lights -> id
Close_shape_culling -> id
Bound_box_screen -> id
Show_ms_frame -> id
View_gr_boundaries -> id
View_rm_boundaries -> id
Show_bound_box -> id
Show_wall_search_rays -> id
Show_dda_test -> id
Show_far_wall_detect -> id
Show_walls_near_you -> id
Show_zone_near_point_cursor -> id
Show_zone_circ -> id
Inspect_wall -> id
Cr_awareness -> id
Show_sound -> id
Cr_status -> id
Mouse_position -> id
Walls_info -> id
Pathing -> id
Show_path_between -> id
Show_writable_values -> id
Show_mouse_click_pos -> id
Debug_get -> id
Debug_put -> id
Muzzle_positions -> id
debugItem :: DebugBool -> Universe -> Maybe [DebugItem]
debugItem = \case
@@ -109,7 +148,6 @@ doDebugGet u =
where
f s = DebugItem s (setClip s)
debugShowPath :: Universe -> DebugItem
debugShowPath u =
DebugItem (u ^. uvDebugPathShowType . to show) f
src/Dodge/Default/Creature.hs
+1
View File
@@ -55,6 +55,7 @@ defaultCreature =
-- , _crStatistics = CreatureStatistics 50 50 50
, _crDeathTimer = 5 -- how long a creature remains standing
-- after a killing blow has been dealt
, _crCrushTimers = mempty
}
--defaultCreatureSkin :: CreatureType
src/Dodge/Render/Lights.hs
+1 -3
View File
@@ -1,6 +1,4 @@
module Dodge.Render.Lights (
lightsToRender,
) where
module Dodge.Render.Lights (lightsToRender) where
import Data.List (sortOn)
import Data.Maybe
src/Dodge/TestString.hs
+6 -1
View File
@@ -33,7 +33,12 @@ import Data.Monoid
import RandomHelp
testStringInit :: Universe -> [String]
testStringInit u = [show $ u ^? uvWorld . input . mouseContext . mcoRotateDist]
--testStringInit u = [show $ u ^? uvWorld . input . mouseContext . mcoRotateDist]
testStringInit u = fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crHP . _HP)
<> fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crPos . _xy)
<> fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crOldPos . _xy)
<> fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crCrushTimers)
<> fmap show (u ^.. uvWorld . cWorld . lWorld . debris . each . dbPos)
-- (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
-- <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
--testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
src/Dodge/WallCreatureCollisions.hs
+62 -18
View File
@@ -6,6 +6,7 @@ module Dodge.WallCreatureCollisions (
crOnWall,
) where
import Data.Foldable
import Linear
import Dodge.Creature.Radius
import Control.Lens
@@ -25,30 +26,64 @@ noclipCheck cfig w c
| otherwise = colCrWall w c
colCrWall :: World -> Creature -> Creature
colCrWall w c
colCrWall w c -- = cornpush . wallpush $ pushthrough c
| p1 == p2 = pushOrCrush ls c
-- | _crPos c' == _crPos c'' = c'
-- | otherwise = c & crPos .~ _crOldPos c
| otherwise = c'
| otherwise = cornpush . wallpush $ pushthrough c
-- | otherwise = wallpush $ pushthrough c
-- | otherwise = c'
where
-- c'' = c' & crPos %~ pushOutFromWalls rad ls
--c' = c & crPos %~ pushOutFromWalls' rad (reverse ls)
c' =
c & crPos . _xy
%~ pushOutFromCorners r ls'
. pushOutFromWalls r ls'
. fst
. flip (collidePoint p1) wls -- check push throughs
-- . flip (collidePointWalls' p1) wls -- check push throughs
cornpush = crPos . _xy %~ pushOutFromCorners r ls'
--wallpush = crPos . _xy %~ pushOutFromWalls r ls'
wallpush = pushCr' wls
pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
-- c' = c & crPos . _xy
-- %~ pushOutFromCorners r ls'
-- . pushOutFromWalls r ls'
-- . 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 $ wlsNearRect (p2 + V2 r r) (p2 - V2 r r) w
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 10]
& crPos . _xy +~ r *^ ep - ap
| otherwise = ecr
where
ep = ecr ^. crPos . _xy
ap = cr ^. crOldPos . _xy
sp = cr ^. crPos . _xy
ecr = foldl' f (cr & crCrushTimers .~ mempty) wls
r = crRad (cr ^. crType)
f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
Just p -> acr & crPos . _xy .~ p & crCrushTimers . at (_wlID wl) ?~ 0
Nothing -> acr
--apushCr :: [Wall] -> Creature -> Creature
--apushCr wls cr = case wallPushList r wls cp of
--a [] -> cr
--a [(p,wl)] -> cr & crPos . _xy .~ p
--a-- [(p1,w1),(p2,w2)] | dd p1 p2 >= 0 ->
--a [(p1,w1),(p2,w2)] ->
--a let v1 = p1 - cp
--a v2 = p2 - cp
--a mp = intersectLineLine p1 (p1 + vNormal v1) p2 (p2 + vNormal v2)
--a --p = fromMaybe (cr ^. crOldPos . _xy) mp
--a p = (cr ^. crOldPos . _xy)
--a in cr & crPos . _xy .~ p
--a-- [(p1,w1),(p2,w2)] -> cr & crPos . _xy .~ p1
--a xs -> cr
--a where
--a dd p1 p2 = dotV (p1 - cp) (p2 - cp)
--a r = crRad (cr ^. crType)
--a cp = cr ^. crPos . _xy
-- the amount to push creatures out from walls, extra to their radius
wallBuffer :: Float
wallBuffer = 0
@@ -65,6 +100,14 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall
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
@@ -76,6 +119,7 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall
pushOrCrush :: [(Point2, Point2)] -> Creature -> Creature
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (crRad (cr ^. crType)) cpos) wls of
[] -> cr
--(p : _) -> cr & crPos . _xy .~ p & crDamage <>~ [Crushing 1000 0]
(p : _) -> cr & crPos . _xy .~ p
where
-- (_:p:_) -> cr
@@ -102,9 +146,9 @@ 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
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
@@ -115,4 +159,4 @@ 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))
| otherwise = p + (rad *^ squashNormalizeV (cCen - p))