From 9801a40b9e7fafa30ead38411cbff4cd5eed0063 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 28 Jun 2022 13:43:37 +0100 Subject: [PATCH] Cleanup zoning --- src/Dodge/Base/Collide.hs | 14 +-- src/Dodge/Debug.hs | 2 +- src/Dodge/Item/Weapon/Grenade.hs | 4 +- src/Dodge/Item/Weapon/Launcher.hs | 2 +- src/Dodge/Item/Weapon/UseEffect.hs | 4 +- src/Dodge/Render/ShapePicture.hs | 3 +- src/Dodge/Update.hs | 5 +- src/Dodge/Update/Camera.hs | 4 +- src/Dodge/Wall/Zone.hs | 5 +- src/Dodge/WallCreatureCollisions.hs | 6 +- src/Dodge/WorldEvent/Shockwave.hs | 2 +- src/Dodge/WorldEvent/SpawnParticle.hs | 2 +- src/Dodge/WorldEvent/ThingsHit.hs | 2 +- src/Dodge/Zone.hs | 135 +++++++++++--------------- 14 files changed, 84 insertions(+), 106 deletions(-) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index db9e95c5c..03f4237b5 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -94,7 +94,7 @@ collidePointTestFilter t sp ep = runIdentity collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall) collidePointWallsFilterStream t sp ep = collidePoint sp ep . S.filter t - . wallsAlongLine sp ep + . wlsNearSeg sp ep overlapSegWalls :: Point2 -> Point2 -> Stream (Of Wall) Identity () -> Stream (Of (Point2,Wall)) Identity () @@ -105,7 +105,7 @@ visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap ( S.span (not . wlIsOpaque . snd) . sortStreamOn (dist sp . fst) . overlapSegWalls sp ep - . wallsAlongLine sp ep ) + . wlsNearSeg sp ep ) allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity () allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20) @@ -236,7 +236,7 @@ collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad) - Note no check on whether the wall is walkable. -} circOnSomeWall :: Point2 -> Float -> World -> Bool circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine) - . wallsNearPoint p + . wlsNearPoint p -- = any (\(x,y) -> circOnSeg x y p rad) -- . fmap _wlLine -- . IM.elems @@ -300,23 +300,23 @@ hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} hasLOS p1 p2 = not . collidePointTestFilter (const True) p1 p2 - . wallsAlongLine p1 p2 + . wlsNearSeg p1 p2 hasButtonLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasButtonLOS #-} hasButtonLOS p1 p2 = not . collidePointTestFilter (not . _wlTouchThrough) p1 p2 - . wallsAlongLine p1 p2 + . wlsNearSeg p1 p2 hasLOSIndirect :: Point2 -> Point2 -> World -> Bool hasLOSIndirect p1 p2 = not . collidePointTestFilter wlIsOpaque p1 p2 - . wallsAlongLine p1 p2 + . wlsNearSeg p1 p2 isWalkable :: Point2 -> Point2 -> World -> Bool isWalkable p1 p2 = not . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 - . wallsAlongLine p1 p2 + . wlsNearSeg p1 p2 canSee :: Int -> Int -> World -> Bool canSee i j w = hasLOS p1 p2 w diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs index b5742c63c..37c62bc36 100644 --- a/src/Dodge/Debug.hs +++ b/src/Dodge/Debug.hs @@ -58,7 +58,7 @@ debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic where --wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls wallsPic = setDepth 25 . color yellow . runIdentity . S.foldMap_ (drawTheWall . _wlLine) - $ wallsAlongLine sp ep w + $ wlsNearSeg sp ep w drawTheWall (a,b) = thickLine 20 [a,b] zonesPic = setDepth 20 $ drawDDA zones zones = ddaExt wlZoneSize sp ep diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index 39b2cea90..e2e0fff5d 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -55,7 +55,7 @@ moveGrenade pj w -- this should maybe -- be wallsAlongLine -- or something vvv - | otherwise = case bounceBall 1 oldPos newPos 4 $ wallsNearPoint newPos w of + | otherwise = case bounceBall 1 oldPos newPos 4 $ wlsNearPoint newPos w of Nothing -> w & props . ix pID %~ normalUpdate Just (p,v) -> w & soundStart (Tap 0) p tapQuietS Nothing @@ -186,7 +186,7 @@ moveRemoteBomb itid time pID w -- this is hacky, should use a version of collidePointWalls' that collides -- circles and walls invShift x = x -.- 5 *.* normalizeV (_pjVel pj) - hitWl = bounceBall 1 oldPos newPos 4 $ wallsNearPoint newPos w + hitWl = bounceBall 1 oldPos newPos 4 $ wlsNearPoint newPos w finalPos = maybe newPos (invShift . fst) hitWl setV v = set (props . ix pID . pjVel) v updateV = maybe id (setV . snd) hitWl diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 956c7a2a0..971624c7c 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -335,7 +335,7 @@ anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool anythingHitCirc rad sp ep w = isJust hitCr || isJust (sequence hitWl) where hitCr = collideCircCrsPoint sp ep rad (_creatures w) - hitWl = collideCircWallsStream sp ep rad $ wallsNearPoint ep w + hitWl = collideCircWallsStream sp ep rad $ wlsNearPoint ep w -- this should probably be wallsOnLine or something explodeRemoteRocket diff --git a/src/Dodge/Item/Weapon/UseEffect.hs b/src/Dodge/Item/Weapon/UseEffect.hs index 39a34ea8a..49878e7ee 100644 --- a/src/Dodge/Item/Weapon/UseEffect.hs +++ b/src/Dodge/Item/Weapon/UseEffect.hs @@ -123,8 +123,8 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems wallBlips :: Point2 -> Float -> World -> [Point2] wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine) - $ S.map (over wlLine swp) (wallsInsideCirc p r w) - <> wallsInsideCirc p r w + $ S.map (over wlLine swp) (wlsInsideCirc p r w) + <> wlsInsideCirc p r w where swp (a,b) = (b,a) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 58238b2aa..c75ce2bd5 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -16,7 +16,6 @@ import Dodge.Graph import Dodge.GameRoom import Dodge.Update.Camera import Dodge.Item.Draw -import Dodge.Wall.Zone --import Dodge.Zone import Geometry import Geometry.Zone @@ -127,7 +126,7 @@ drawFarWallDetect w = setLayer DebugLayer . color yellow . concatMap (\q -> line [ p - , fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w + , fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg p q w ] ) $ runIdentity $ S.toList_ $ streamViewpoints p w where diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 9f7385423..1c1848bf2 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -97,7 +97,10 @@ functionalUpdate cfig w = checkEndGame $ updateCloseObjects w where --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w - zoneClouds = set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w)) + +zoneClouds :: World -> World +zoneClouds w = w & set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w)) + where cloudInZone cl = insertInZoneWith x y (++) [cl] where V2 x y = clZoneOfPoint $ stripZ $ _clPos cl diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index b4fce9535..f2164928a 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -151,7 +151,7 @@ rotateToOverlappingWall :: World -> World rotateToOverlappingWall w = maybe id (doWallRotate . snd) - (overlapCircWallsClosest p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w)) + (overlapCircWallsClosest p (_crRad cr + 5) (S.filter _wlRotateTo $ wlsNearPoint p w)) w where cr = you w @@ -224,7 +224,7 @@ farWallDistDirection p w = boundPoints $ S.map f vps where f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q)) - wls q = S.filter wlIsOpaque $ wallsAlongLine p q w + wls q = S.filter wlIsOpaque $ wlsNearSeg p q w findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine vps = streamViewpoints p w diff --git a/src/Dodge/Wall/Zone.hs b/src/Dodge/Wall/Zone.hs index d2f91ff4d..ce570e173 100644 --- a/src/Dodge/Wall/Zone.hs +++ b/src/Dodge/Wall/Zone.hs @@ -7,12 +7,9 @@ import Dodge.Base import Control.Lens --import Data.Foldable -import Streaming +--import Streaming import qualified Streaming.Prelude as S -zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity () -zoneOfWall = uncurry (zoneOfSeg wlZoneSize) . _wlLine - insertWallInZones :: Wall -> World -> World insertWallInZones wl = wallsZone . znObjects %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl))) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 011af3017..a49a2d298 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -47,8 +47,8 @@ colCrWall w c p2 = _crPos c ls = _wlLine <$> wls ls' = filter (uncurry $ isLHS p1) ls - wls' = S.filter (not . _wlWalkable) $ wallsNearPoint p2 w - wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wallsNearPoint p2 w + wls' = S.filter (not . _wlWalkable) $ wlsNearPoint p2 w + wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wlsNearPoint p2 w --wallPoints = map fst ls -- the amount to push creatures out from walls, extra to their radius @@ -88,7 +88,7 @@ crOnWall :: Creature -> World -> Bool crOnWall cr = runIdentity . S.any_ (uncurry (circOnSeg p r) . _wlLine) . S.filter (not . _wlWalkable) - . wallsNearPoint p + . wlsNearPoint p where p = _crPos cr r = _crRad cr diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index 81b51cce5..400b7d1f9 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -70,7 +70,7 @@ mvShockwave is w pt w' id hitBlocks - hitBlocks = S.map snd . overlapCircWalls p rad $ wallsInsideCirc p rad w + hitBlocks = S.map snd . overlapCircWalls p rad $ wlsInsideCirc p rad w -- this is not expansive enough damCr cr | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 0195c0994..881062be4 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -214,7 +214,7 @@ damageInArea crt wlt pt w = damwls damcrs w' id . S.filter wlt - $ wallsNearPoint p w' + $ wlsNearPoint p w' hiteff = _ptHitEff pt pt -- | At writing the radius is half the size of the effect area diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index e65c9cf12..468a498ef 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -60,4 +60,4 @@ wlsHit sp ep | sp == ep = const mempty | otherwise = sortStreamOn (dist sp . fst) . overlapSegWalls sp ep - . wallsAlongLine sp ep + . wlsNearSeg sp ep diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 9c13a599c..b37171771 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -1,22 +1,21 @@ module Dodge.Zone - ( crZoneOfPoint - , wallsNearPoint - , wallsAlongLine + ( zoneOfSeg + , zoneOfCreature + , zoneOfWall + , zoneOfSight + , zoneAroundPoint + , wlsNearPoint + , crsNearPoint + , clsNearPoint + , wlsNearSeg , crsNearSeg - , wallsInsideCirc + , wlsInsideCirc , crsInsideCirc , lookLookups - , zoneOfSeg , zoneNearPointIP - , zoneNearPoint - , zoneOfCreature , clZoneOfPoint - , clsNearPoint - , zoneOfSight - , flattenIMIMIM + , crZoneOfPoint , wlZoneOfPoint - , crsNearPoint - , creaturesAlongLine , module Dodge.Zone.Size ) where @@ -25,7 +24,6 @@ import Dodge.Data --import Dodge.Base.Window import Geometry import Geometry.Zone -import qualified FoldlHelp as L import qualified Streaming.Prelude as S import StreamingHelp @@ -33,34 +31,27 @@ import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens -wlZoneOfPoint :: Point2 -> Int2 -wlZoneOfPoint = zoneOfPoint wlZoneSize - -clZoneOfPoint :: Point2 -> Int2 -clZoneOfPoint = zoneOfPoint clZoneSize - -crZoneOfPoint :: Point2 -> Int2 -crZoneOfPoint = zoneOfPoint crZoneSize - zoneOfSeg :: Float -> Point2 -> Point2 -> StreamOf Int2 ---zoneOfLineStream = ddaSqStream zoneSize zoneOfSeg = ddaStream -zoneOfCreature :: Creature -> StreamOf Int2 -zoneOfCreature cr = zoneInsideCirc crZoneSize (_crPos cr) (_crRad cr) - zoneInsideCirc :: Float -> Point2 -> Float -> StreamOf Int2 zoneInsideCirc x p r = ddaSqStream x (p +.+ V2 r r) (p -.- V2 r r) +zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity () +zoneOfWall = uncurry (zoneOfSeg wlZoneSize) . _wlLine + +zoneOfCreature :: Creature -> StreamOf Int2 +zoneOfCreature cr = zoneInsideCirc crZoneSize (_crPos cr) (_crRad cr) + zoneNearPointIP :: Point2 -> [(Int,Int)] zoneNearPointIP p = [(a,b) | a <- [x-1..x+1] , b <- [y-1..y+1] ] where V2 x y = wlZoneOfPoint p -zoneNearPoint :: Point2 -> Stream (Of (V2 Int)) Identity () -zoneNearPoint p = S.each [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ] +zoneAroundPoint :: Float -> Point2 -> StreamOf Int2 +zoneAroundPoint s p = S.each [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ] where - V2 x y = wlZoneOfPoint p + V2 x y = zoneOfPoint s p --zoneOfBounds :: Float -> (Float,Float,Float,Float) -> Stream (Of Int2) Identity () --zoneOfBounds x (n,s,e,w) = ddaSqStream x (V2 n e) (V2 s w) @@ -87,59 +78,47 @@ lookLookup i j z = case IM.lookup i z of lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a] lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs -clsNearPoint :: Point2 -> World -> Stream (Of Cloud) Identity () -clsNearPoint p w = S.each . fromMaybe mempty $ w ^? cloudsZone . znObjects . ix x . ix y - where - V2 x y = clZoneOfPoint p +extractFromZone :: Zone a -> Int2 -> Maybe a +extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y --- TODO check whether/when nubbing of walls is necessary -wallsAlongLine :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity () -wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg wlZoneSize sp ep - where - f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j +nearPoint :: (Foldable t,Monoid (t a)) + => Float -> (World -> Zone (t a)) -> Point2 -> World -> StreamOf a +nearPoint s f p w = S.each . fromMaybe mempty $ extractFromZone (f w) (zoneOfPoint s p) -crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature -crsNearSeg sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg crZoneSize sp ep - where - f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j +clsNearPoint :: Point2 -> World -> StreamOf Cloud +clsNearPoint = nearPoint clZoneSize _cloudsZone -crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature -crsInsideCirc p r w = S.concat $ S.mapMaybe f $ zoneInsideCirc crZoneSize p r - where - f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j - -wallsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity () -wallsInsideCirc p r w = S.concat $ S.mapMaybe f $ zoneInsideCirc wlZoneSize p r - where - f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j - -wallsNearPoint :: Point2 -> World -> StreamOf Wall -wallsNearPoint p = S.each . fromMaybe mempty . (^? wallsZone . znObjects . ix x . ix y) - where - V2 x y = wlZoneOfPoint p - -flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a -flattenIMIMIM = IM.unions . fmap IM.unions - -creatureNearPoint :: Point2 -> World -> Maybe Creature -creatureNearPoint = creatureNearPointI 1 - -creatureNearPointI :: Int -> Point2 -> World -> Maybe Creature -creatureNearPointI n p = L.fold (L.minimumOn (dist p . _crPos)) . creaturesNearPointI n p +wlsNearPoint :: Point2 -> World -> StreamOf Wall +wlsNearPoint = nearPoint wlZoneSize _wallsZone crsNearPoint :: Point2 -> World -> StreamOf Creature -crsNearPoint p = S.each . fromMaybe mempty . (^? creaturesZone . znObjects . ix x . ix y) - where - V2 x y = crZoneOfPoint p +crsNearPoint = nearPoint crZoneSize _creaturesZone -creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature -creaturesNearPointI n p w = IM.unions - [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]] - where - V2 x y = crZoneOfPoint p - f i m = fromMaybe IM.empty $ IM.lookup i m +nearSeg :: Foldable t => Float -> (World -> Zone (t a)) -> Point2 -> Point2 -> World -> StreamOf a +nearSeg s f p r w = S.concat $ S.mapMaybe (extractFromZone (f w)) + $ zoneOfSeg s p r -creaturesAlongLine :: Point2 -> Point2 -> World -> Stream (Of Creature) Identity () -creaturesAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg crZoneSize sp ep - where - f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j +wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity () +wlsNearSeg = nearSeg wlZoneSize _wallsZone + +crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature +crsNearSeg = nearSeg crZoneSize _creaturesZone + +insideCirc :: Foldable t => Float -> (World -> Zone (t a)) -> Point2 -> Float -> World -> StreamOf a +insideCirc s f p r w = S.concat $ S.mapMaybe (extractFromZone (f w)) + $ zoneInsideCirc s p r + +wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity () +wlsInsideCirc = insideCirc wlZoneSize _wallsZone + +crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature +crsInsideCirc = insideCirc crZoneSize _creaturesZone + +wlZoneOfPoint :: Point2 -> Int2 +wlZoneOfPoint = zoneOfPoint wlZoneSize + +clZoneOfPoint :: Point2 -> Int2 +clZoneOfPoint = zoneOfPoint clZoneSize + +crZoneOfPoint :: Point2 -> Int2 +crZoneOfPoint = zoneOfPoint crZoneSize