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

Cleanup zoning

Browse Source
This commit is contained in:
justin
2022-06-28 13:43:37 +01:00
parent e770fba7bf
commit 9801a40b9e
14 changed files with 84 additions and 106 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+7 -7
View File
@@ -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
src/Dodge/Debug.hs
+1 -1
View File
@@ -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
src/Dodge/Item/Weapon/Grenade.hs
+2 -2
View File
@@ -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
src/Dodge/Item/Weapon/Launcher.hs
+1 -1
View File
@@ -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
src/Dodge/Item/Weapon/UseEffect.hs
+2 -2
View File
@@ -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)
src/Dodge/Render/ShapePicture.hs
+1 -2
View File
@@ -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
src/Dodge/Update.hs
+4 -1
View File
@@ -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
src/Dodge/Update/Camera.hs
+2 -2
View File
@@ -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
src/Dodge/Wall/Zone.hs
+1 -4
View File
@@ -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)))
src/Dodge/WallCreatureCollisions.hs
+3 -3
View File
@@ -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
src/Dodge/WorldEvent/Shockwave.hs
+1 -1
View File
@@ -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
src/Dodge/WorldEvent/SpawnParticle.hs
+1 -1
View File
@@ -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
src/Dodge/WorldEvent/ThingsHit.hs
+1 -1
View File
@@ -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
src/Dodge/Zone.hs
+57 -78
View File
@@ -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