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

Improve wall squashing further

Browse Source
This commit is contained in:
justin
2026-03-26 20:25:59 +00:00
parent 62a37388e7
commit 0ddedf7fd6
9 changed files with 99 additions and 79 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+7 -7
View File
@@ -34,6 +34,7 @@ module Dodge.Base.Collide (
collide3,
) where
import Data.Foldable
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.Monad
@@ -186,11 +187,11 @@ wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y)
-- this COULD be written in terms of collidePointWallsFilterStream, TODO test
-- whether this is actually faster
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Bool
{-# INLINE collidePointTestFilter #-}
collidePointTestFilter t sp ep =
any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
. filter t
. IM.filter t
---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
---- whether this is actually faster
@@ -209,9 +210,9 @@ collidePointWallsFilter t sp ep = collidePoint sp ep . IM.filter t . wlsNearSeg
-- {-# INLINE overlapSegWalls #-}
-- overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2, Wall)]
overlapSegWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
{-# INLINE overlapSegWalls #-}
overlapSegWalls sp ep = mapMaybe $
overlapSegWalls sp ep = IM.mapMaybe $
\wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
@@ -219,8 +220,8 @@ visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
visibleWalls sp ep =
takeUntil (wlIsOpaque . snd)
. sortOn (dist sp . fst)
. overlapSegWalls sp ep
. IM.elems
. overlapSegWalls sp ep
. wlsNearSeg sp ep
allVisibleWalls :: World -> [(Point2, Wall)]
@@ -298,7 +299,6 @@ hasLOS :: Point2 -> Point2 -> World -> Bool
hasLOS p1 p2 =
not
. collidePointTestFilter (const True) p1 p2
. IM.elems
. wlsNearSeg p1 p2
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
@@ -315,7 +315,7 @@ hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
hasLOSIndirect p1 p2 =
not
. collidePointTestFilter wlIsOpaque p1 p2
. IM.elems
-- . IM.elems
. wlsNearSeg p1 p2
canSee :: Int -> Int -> World -> Bool
src/Dodge/Data/WorldEffect.hs
-1
View File
@@ -33,7 +33,6 @@ data WdWd
| MakeStartCloudAt Point3
| TorqueCr Float Int
| WdWdNegateTrig Int
-- | WdWdFromItCrixWdWd (LabelDoubleTree ComposeLinkType Item) Int ItCrWdWd
| MakeTempLight LSParam Int
| MakeTempLightFade Float LSParam Int
| UseInvItem Int Int -- invid presstime
src/Dodge/Inventory.hs
+1 -1
View File
@@ -142,7 +142,7 @@ updateCloseObjects w =
x <- lw ^? terminals . ix tid . tmStatus
return (x /= TerminalDeactivated)
_ -> True
isclose x = dist y x < 40 && hasButtonLOS y x w
isclose x = dist y x < 30 && hasButtonLOS y x w
y = you w ^. crPos . _xy
changeSwapSelSet :: Int -> World -> World
src/Dodge/Inventory/SelectionList.hs
+3 -2
View File
@@ -236,8 +236,9 @@ closeButtonToSelectionItem w i = do
btText :: Button -> String
btText bt = case _btEvent bt of
ButtonPress {} -> "BUTTON"
ButtonSwitch {_btOn = t} -> if t then "SWITCH\\" else "SWITCH/"
ButtonDumbSwitch {} -> "SWITCH"
--ButtonSwitch {_btOn = t} -> if t then "SWITCH\\" else "SWITCH/"
ButtonSwitch {} -> "SWITCH"
ButtonDumbSwitch {} -> "SWITCH" -- do we want to show switch status?
ButtonAccessTerminal i -> "TERMINAL " ++ show i
closeItemToTextPictures :: Item -> ([String], Color)
src/Dodge/TestString.hs
+17
View File
@@ -1,6 +1,7 @@
{-# OPTIONS_GHC -Wno-unused-imports #-}
module Dodge.TestString where
import Dodge.WallCreatureCollisions
import Data.List ((\\))
import ShortShow
import Geometry
@@ -34,6 +35,22 @@ import RandomHelp
testStringInit :: Universe -> [String]
testStringInit u = (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crWallTouch)
<> fromMaybe [] (do
w1 <- u ^? uvWorld . cWorld . lWorld . walls . ix 18
w2 <- u ^? uvWorld . cWorld . lWorld . walls . ix 61
let
f = uncurry (-) . (^. wlLine)
g = argV . f
h = normalizeV . uncurry (-) . (^. wlLine)
a = angleVV (f w1) (f w2)
return [show $ wlWlCrush w1 w2, show a , show (f w1), show (f w2)
, show $ g w1
, show $ g w2
, show $ h w1
, show $ h w2
, show (norm (h w1 + h w2))
]
)
-- <> (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/WallCreatureCollisions.hs
+10 -4
View File
@@ -1,5 +1,7 @@
-- | Deals with moving creature wall collisions.
module Dodge.WallCreatureCollisions (colCrsWalls) where
module Dodge.WallCreatureCollisions (colCrsWalls,
wlWlCrush
) where
import qualified Data.IntMap.Strict as IM
import Control.Lens
@@ -45,7 +47,8 @@ pushCr wls cr
& crPos . _xy .~ ap
| otherwise = ecr
where
twls = IM.elems $ IM.restrictKeys wls (ecr ^. crWallTouch)
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
ap = cr ^. crOldPos . _xy
sp = cr ^. crPos . _xy
@@ -60,9 +63,12 @@ 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
wlWlCrush w1 w2 = norm (f w1 + f w2) < 0.5
where
f = uncurry (-) . (^. wlLine)
f = normalizeV . uncurry (-) . (^. wlLine)
--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
src/Dodge/WorldEffect.hs
-3
View File
@@ -45,9 +45,6 @@ doWdWd = \case
SoundStart so p sid mi -> soundStart so p sid mi
WdWdNegateTrig trid -> cWorld . lWorld . triggers . ix trid %~ not
WdWdSetSoundFilter x -> wSoundFilter .~ x
-- WdWdFromItCrixWdWd it crid f -> \w -> fromMaybe w $ do
-- cr <- w ^? cWorld . lWorld . creatures . ix crid
-- return $ doItCrWdWd f it cr w
MakeTempLight _ 0 -> id
MakeTempLight x t ->
(cWorld . lWorld . lights .:~ x)
src/Dodge/WorldEvent/ThingsHit.hs
+5 -5
View File
@@ -154,19 +154,19 @@ thingsHitExceptCr (Just cid) sp ep = filter t . thingsHit sp ep
t = (Just cid /=) . (^? _2 . _Left . crID)
wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)]
wlsHit sp ep = sortOn (dist sp . fst) . wlsHitUnsorted sp ep
wlsHit sp ep = sortOn (dist sp . fst) . IM.elems . wlsHitUnsorted sp ep
---- pushes out any hit point by one
wlHitPos :: Point2 -> Point2 -> World -> Point2
wlHitPos sp ep = maybe ep ((+ normalize (ep - sp)) . fst) . safeHead . wlsHit sp ep
wlsHitUnsorted :: Point2 -> Point2 -> World -> [(Point2, Wall)]
wlsHitUnsorted :: Point2 -> Point2 -> World -> IM.IntMap (Point2, Wall)
wlsHitUnsorted sp ep
| sp == ep = const mempty
| otherwise = overlapSegWalls sp ep . IM.elems . wlsNearSeg sp ep
| otherwise = overlapSegWalls sp ep . wlsNearSeg sp ep
wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
wlsHitRadial p r = mapMaybe f . IM.elems . wlsNearCirc p r
wlsHitRadial :: Point2 -> Float -> World -> IM.IntMap (Point2, Wall)
wlsHitRadial p r = IM.mapMaybe f . wlsNearCirc p r
where
--f wl = uncurry (intersectSegSeg p (p - r *.* v)) (_wlLine wl) <&> (,wl)
f wl = mhp <&> (,wl)