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

Improve wall crushing

Browse Source
This commit is contained in:
justin
2026-03-28 21:43:06 +00:00
parent 2db4e9bc6e
commit 08fcc4baab
12 changed files with 176 additions and 106 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Door.hs
+1
View File
@@ -33,6 +33,7 @@ data Door = Door
, _drZeroPos :: (Point2,Float)
, _drOnePos :: (Point2,Float)
, _drLerp :: Float
, _drOldLerp :: Float
, _drFootPrint :: IM.IntMap (Point2,Point2)
, _drHP :: Int
, _drPushedBy :: PushSource
src/Dodge/Data/Wall/Structure.hs
+1
View File
@@ -3,6 +3,7 @@
module Dodge.Data.Wall.Structure where
--import Geometry.Data
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
src/Dodge/Default/Door.hs
+1
View File
@@ -11,6 +11,7 @@ defaultDoor =
, _drZeroPos = (0, 0)
, _drOnePos = (0, 0)
, _drLerp = 0
, _drOldLerp = 0
, _drFootPrint = mempty
, _drHP = 10000
, _drPushedBy = PushesItself
src/Dodge/Door.hs
+4 -1
View File
@@ -38,8 +38,9 @@ doDoorMount pa w = \case
& _2 . each . vxPos . _xy %~ shiftPointBy pa
)
-- do the mounts need to be done if there is no lerping?
doorLerp :: Float -> Door -> World -> (S.Set Int2, World)
doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do
doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) $ setOldLerp w) $ do
x <- newlerp
let ps = wlposs x
ps' = wlposs (dr ^. drLerp)
@@ -52,8 +53,10 @@ doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do
f x
& playSound x
& cWorld . lWorld . doors . ix drid . drLerp .~ x
& setOldLerp
)
where
setOldLerp = cWorld . lWorld . doors . ix drid . drOldLerp .~ (dr ^. drLerp)
domounts x w' = foldl' (doDoorMount (doDoorLerp dr x)) w' (dr ^. drMounts)
f = ifoldl' (flip . moveWallID) w . wlposs
wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
src/Dodge/Placement/Instance/LightSource.hs
+10
View File
@@ -14,6 +14,7 @@ module Dodge.Placement.Instance.LightSource (
spanColLightBlackI,
spanLightI,
spanLightY,
spanLightL,
mntLightLnkCond',
spanLS,
mntLightLnkShape,
@@ -178,6 +179,15 @@ spanLightY l x y z =
f p = putShape $ thinHighBar h p (l + normalize (l-p))
h = 95
spanLightL :: Point2 -> Point2 -> Point2 -> Placement
spanLightL l x y =
ps0j (PutLS $ lsColPos 0.75 (addZ (h -5) l)) $
ps0j (f x) $
sps0 (f y)
where
f p = putShape $ thinHighBar h p (l + normalize (l-p))
h = 95
--extendAway :: Point2 -> Point2 -> Point2
--extendAway p x = p +.+ squashNormalizeV (p -.- x)
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+1 -1
View File
@@ -30,7 +30,7 @@ plDoor dr wl gw =
lerposa = doDoorLerp dr (dr ^. drLerp)
addWalls =
insertStructureWalls
(`DoorPart` isauto)
(\x -> DoorPart x isauto)
wl
(map fst pps & each %~ shiftPointBy lerposa)
drid
src/Dodge/Room/LongDoor.hs
+43 -24
View File
@@ -148,18 +148,23 @@ slowCrushRoom = do
& rmPmnts .~ [spanLightI (V2 0 60) (V2 35 100)
, spanLightI (V2 220 60) (V2 185 100)
]
crs <- takeOne [[]
, [sPS (V2 200 10) (0.8* pi) randC1]
, [sPS (V2 200 10) (0.8* pi) randC1 , sPS (V2 210 20) (0.8* pi) randC1]
, [sPS (V2 200 80) pi randC1]
, [sPS (V2 200 80) pi randC1 , sPS (V2 210 90) pi randC1]
]
return $ rm'
& rmBound .:~ rectNSWE 0 (-50) 0 220
& rmLinks %~ setOutLinks (\rl -> onside East $ rl ^. rlType)
& rmLinks %~ setInLinks (\rl -> onside West $ rl ^. rlType)
& rmPmnts .:~
(ps0 (PutTrigger False) $ \i -> Just $
& rmPmnts <>~
[ps0 (PutTrigger False) $ \i -> Just $
pContID (apos West) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
pContID (apos East) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
sps0 (PutDoor (dr & drTrigger .~ WdTrig i) defaultDoorWall) & plIDCont . mapped . mapped ?~
sps0 (PutDoor (dr1 & drTrigger .~ WdTrig i) defaultDoorWall)
)
] <> crs
where
onside x s = (OnEdge x `S.member` s)
|| (OnEdge South `S.member` s && FromEdge x 0 `S.member` s)
@@ -180,36 +185,50 @@ slowCrushRoom = do
UnusedLink s -> onside edge s
_ -> False
slowCrushRoom' :: RandomGen g => State g Room
slowCrushRoom' = do
rm <- shuffleLinks =<< roomRectAutoLights 200 100
slowCrush90 :: RandomGen g => State g Room
slowCrush90 = do
rm <- shuffleLinks =<< roomRectAutoLights 170 100
(ilinks, olinks) <- shufflePair (cornlinks,onside West)
let rm' = removeLights rm
& rmPmnts .~ [spanLightI (V2 0 60) (V2 35 100)
, spanLightI (V2 200 60) (V2 165 100)
, spanLightL (V2 120 39) (V2 170 39) (V2 120 0)
]
crs <- takeOne [[] ]
return $ rm'
& rmLinks %~ setOutLinksByType (OnEdge East)
& rmLinks %~ setInLinksByType (OnEdge West)
& rmPmnts .:~
(ps0 (PutTrigger False) $ \i -> Just $
pContID (apos West 5) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
pContID (apos East (-5)) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
& rmBound <>~ [rectNSWE 0 (-55) 0 110
, rectNSWE 100 40 170 220
]
& rmLinks %~ setOutLinks (\rl -> olinks $ rl ^. rlType)
& rmLinks %~ setInLinks (\rl -> ilinks $ rl ^. rlType)
& rmPmnts <>~
[ps0 (PutTrigger False) $ \i -> Just $
pContID (spos ilinks) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
pContID (spos olinks) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
sps0 (PutDoor (dr & drTrigger .~ WdTrig i) defaultDoorWall) & plIDCont . mapped . mapped ?~
sps0 (PutDoor (dr1 & drTrigger .~ WdTrig i) defaultDoorWall)
)
] <> crs
where
onside x s = (OnEdge x `S.member` s)
|| (OnEdge South `S.member` s && FromEdge x 0 `S.member` s)
|| (OnEdge North `S.member` s && FromEdge x 0 `S.member` s)
cornlinks s =
(OnEdge South `S.member` s && FromEdge East 0 `S.member` s)
|| (OnEdge East `S.member` s && FromEdge South 0 `S.member` s)
dr = defaultDoor
& drUpdate .~ DoorLerp 0.01
& drZeroPos .~ (V2 65 (-40), 0)
& drOnePos .~ (V2 65 50, 0)
& drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 35 50))
& drZeroPos .~ (V2 75 (-5), 0)
& drOnePos .~ (V2 75 50, 0)
& drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 34 50))
dr1 = dr
& drOnePos .~ (V2 135 (-40), 0)
& drZeroPos .~ (V2 135 50, 0)
apos edge x = (rprBool (t edge) & psSelect . mapped . mapped . _Just . _1 %~ (psRot +~ pi) . (psPos +~ V2 x 0))
t edge rp _ = case _rpType rp of
UnusedLink s -> OnEdge edge `S.member` s
& drOnePos .~ (V2 190 70, 0)
& drZeroPos .~ (V2 140 70, 0)
& drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 30 29))
f ps = case ps of
PS _ r -> ps & psRot +~ pi & psPos +~ rotateV r (V2 0 (-5))
_ -> ps
spos h = (rprBool (t' h) & psSelect . mapped . mapped . _Just . _1 %~ f)
t' h rp _ = case _rpType rp of
UnusedLink s -> h s
_ -> False
slowDoorRoom :: RandomGen g => State g Room
src/Dodge/Room/Tutorial.hs
+1 -1
View File
@@ -55,7 +55,7 @@ tutAnoTree = do
foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, tToBTree "slowCrush" . return . cleatOnward <$> slowCrushRoom
, tToBTree "slowCrush" . return . cleatOnward <$> slowCrush90
, corDoor
, chasmSpitTerminal
--a , return $ tToBTree "cor" $ return $ cleatOnward corridor
src/Dodge/TestString.hs
+2 -2
View File
@@ -34,8 +34,8 @@ import Data.Monoid
import RandomHelp
testStringInit :: Universe -> [String]
testStringInit u =
(fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage . strideAmount)
testStringInit u = [fromMaybe "" $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crName]
-- (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage . strideAmount)
-- a <> fromMaybe [] (do
-- a w1 <- u ^? uvWorld . cWorld . lWorld . walls . ix 18
-- a w2 <- u ^? uvWorld . cWorld . lWorld . walls . ix 61
src/Dodge/Wall/Move.hs
+2 -2
View File
@@ -21,9 +21,9 @@ moveWallID wlid wlline w = case w ^? cWorld . lWorld . walls . ix wlid of
Just wl -> moveWall wlid wl wlline w
moveWall :: Int -> Wall -> (Point2, Point2) -> World -> World
moveWall wlid wl wlline w =
moveWall wlid wl xy w =
w & cWorld . lWorld . walls . ix wlid .~ newwl
& deleteWallFromZones wl
& insertWallInZones newwl
where
newwl = wl{_wlLine = wlline}
newwl = wl & wlLine .~ xy
src/Dodge/WallCreatureCollisions.hs
+45 -16
View File
@@ -1,8 +1,11 @@
-- | Deals with moving creature wall collisions.
module Dodge.WallCreatureCollisions (colCrsWalls,
wlWlCrush
) where
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
@@ -26,7 +29,7 @@ colCrWall :: World -> Creature -> Creature
colCrWall w c = cornpush . wallpush $ pushthrough c
where
cornpush = crPos . _xy %~ pushOutFromCorners r ls'
wallpush = pushCr wls
wallpush = pushCr (w ^. cWorld . lWorld) wls
pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
r = crRad (c ^. crType) + wallBuffer
p1 = c ^. crOldPos . _xy
@@ -37,34 +40,60 @@ colCrWall w c = cornpush . wallpush $ pushthrough c
notff x = x ^. wlMaterial /= ForceField
-- might want to check angled crushing
pushCr :: IM.IntMap Wall -> Creature -> Creature
pushCr wls cr
| (dist ep sp > r && dist ep ap > r)
|| wlsCrush twls
=
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]
& 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.restrictKeys wls (ecr ^. crWallTouch) -- `IM.union` stwls
ep = ecr ^. crPos . _xy
-- ep = ecr ^. crPos . _xy
ap = cr ^. crOldPos . _xy
sp = cr ^. crPos . _xy
-- sp = cr ^. crPos . _xy
ecr = foldl' f (cr & crWallTouch .~ mempty) wls
r = crRad (cr ^. crType)
f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
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
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
wlWlCrush :: Wall -> Wall -> Bool
wlWlCrush w1 w2 = norm (f w1 + f w2) < 0.2
--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)
-- the amount to push creatures out from walls, extra to their radius