diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 5efaa1f79..6e0bed495 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -16,8 +16,10 @@ module Dodge.Base.Collide , wlIsOpaque , wlIsSeeThrough , wallsOnCirc + , wallsOnCirc' , wallsOnLineHit , collideCircWalls + , collideCircWallsList -- , collideCircWalls' , circOnSomeWall , collidePointWalls @@ -26,6 +28,7 @@ module Dodge.Base.Collide -- , collidePointWallsL , collidePointWallsFilt , overlapCircWallsReturnWall + , overlapCircWallsReturnWall' , collideCircCrsPoint , collideCircCreatures , collidePointCreatures @@ -235,6 +238,11 @@ wallsOnCirc p r = IM.filter f where f wl = uncurry circOnSeg (_wlLine wl) p r +wallsOnCirc' :: Point2 -> Float -> [Wall] -> [Wall] +wallsOnCirc' p r = filter f + where + f wl = uncurry circOnSeg (_wlLine wl) p r + -- | Looks for overlap of a circle with walls. -- If found, gives wall overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall @@ -243,6 +251,14 @@ overlapCircWallsReturnWall p rad where f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b +-- | Looks for overlap of a circle with walls. +-- If found, gives wall +overlapCircWallsReturnWall' :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe Wall +overlapCircWallsReturnWall' p rad + = runIdentity . L.purely S.fold_ (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine)) + where + f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b + -- | Looks for any collision of a circle with walls. -- If found, gives point and reflection velocity, reflection damped in normal. -- note that in this version the circle can overlap the wall @@ -296,6 +312,25 @@ collidePointWallsFilt t p1 p2 = collidePointWalls' p1 p2 . IM.filter t -- ) -- where -- g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) +-- | Looks for first collision of a circle with walls. +-- If found, gives point and reflection velocity, reflection damped in normal. +collideCircWallsList :: Point2 -> Point2 -> Float -> [Wall] -> Maybe (Point2,Point2) +collideCircWallsList p1 p2 rad + = safeMinimumOn (dist p1 . fst) + . mapMaybe + (( \(x:y:_) -> fmap + ((, reflectInParam 0.5 (x -.- y) (p2 -.- p1)) + . (+.+ normalizeV (vNormal (x -.- y))) + ) + (intersectSegSeg p1 p2 x y) + ) + . shiftByRad . _wlLine + ) + where + shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) + [a +.+ rad *.* normalizeV (a -.-b) + ,b +.+ rad *.* normalizeV (b -.-a) + ] -- | Looks for first collision of a circle with walls. -- If found, gives point and reflection velocity, reflection damped in normal. @@ -379,11 +414,12 @@ collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad) {- | Test if a circle collides with any wall. - Note no check on whether the wall is walkable. -} circOnSomeWall :: Point2 -> Float -> World -> Bool -circOnSomeWall p rad - = any (\(x,y) -> circOnSeg x y p rad) - . fmap _wlLine - . IM.elems +circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg' p rad) . _wlLine) . wallsNearPoint p +-- = any (\(x,y) -> circOnSeg x y p rad) +-- . fmap _wlLine +-- . IM.elems +-- . wallsNearPoint p {- | Adds the distance to the creature radius, tests whether the center is in the circle of this size centered at the point -} crsNearPoint :: Float -> Point2 -> World -> Bool diff --git a/src/Dodge/Beam.hs b/src/Dodge/Beam.hs index 09efd2e58..39054a268 100644 --- a/src/Dodge/Beam.hs +++ b/src/Dodge/Beam.hs @@ -114,10 +114,11 @@ defaultArcStep itparams w (ArcStep p dir _) = do . filter (\cr -> dist center (_crPos cr) < csize) . IM.elems $ _creatures w - wlsnearpoint = wallsNearPoint p w + wlsnearpoint = wallsNearPoint' p w mwl = listToMaybe . sortOn (dist p . fst) - . mapMaybe (\ q -> collidePointWallsWall p (center +.+ q) wlsnearpoint) + . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w) + -- collidePointWallsWall and wlsnearpoint $ polyCirc 6 csize f (q,wl) = ArcStep q dir (Just $ Right wl) g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (Just $ Left cr) diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index 3f3b45ef5..cdd6d9ab7 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -52,7 +52,7 @@ moveGrenade pj w | _pjTimer pj <= 0 = w & props %~ IM.delete pID & _pjPayload pj (_prPos (_props w IM.! pID)) - | otherwise = case collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w of + | otherwise = case collideCircWallsList oldPos newPos 4 $ wallsNearPoint' newPos w of Nothing -> w & props . ix pID %~ normalUpdate Just (p,v) -> w & soundStart (Tap 0) p tapQuietS Nothing @@ -182,7 +182,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 = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w + hitWl = collideCircWallsList oldPos newPos 4 $ wallsNearPoint' 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 54082b8d6..11c4e6e72 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -336,7 +336,7 @@ anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool anythingHitCirc rad sp ep w = isJust $ hitCr <|> hitWl where hitCr = fst <$> collideCircCrsPoint sp ep rad (_creatures w) - hitWl = fst <$> collideCircWalls sp ep rad (wallsNearPoint ep w) + hitWl = fst <$> collideCircWallsList sp ep rad (wallsNearPoint' ep w) -- this should probably be wallsOnLine or something explodeRemoteRocket diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 74bb74f09..6fb28ac33 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -348,7 +348,8 @@ updateCloud w c newPos@(V3 _ _ npz) = oldPos +.+.+ newVel newPos2 = stripZ newPos -- the following only tests for the first collision with a wall - hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w + --hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w + hitWl = reflectPointWallsDamp (const True) 1 oldPos2 newPos2 w finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl -- allowing clouds at/above height 75 causes graphical glitches 22.05.23 finalVel = addZ nvz $ maybe newVel2 snd hitWl diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 90407dd0b..05f566f08 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -143,7 +143,7 @@ ifConfigWallRotate cfig w rotateToOverlappingWall :: World -> World rotateToOverlappingWall w = maybe w dowallrotate - $ overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w) + $ overlapCircWallsReturnWall' p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w) where dowallrotate wl' = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w rotateUsing a diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 738b4b303..321b5c2b5 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -18,6 +18,8 @@ import Data.Function import Control.Lens import qualified Data.IntMap.Strict as IM +import qualified Streaming.Prelude as S + colCrsWalls :: Configuration -> World -> World colCrsWalls cfig w = w & creatures %~ fmap (noclipCheck cfig w) @@ -42,9 +44,9 @@ colCrWall w c rad = _crRad c + wallBuffer p1 = _crOldPos c p2 = _crPos c - ls = IM.elems $ _wlLine <$> wls + ls = _wlLine <$> wls ls' = filter (uncurry $ isLHS p1) ls - wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w + wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wallsNearPoint p2 w --wallPoints = map fst ls -- the amount to push creatures out from walls, extra to their radius @@ -81,9 +83,9 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of -- note the inclusion of endpoints in circOnSeg crOnWall :: Creature -> World -> Bool -crOnWall cr = any (\(a,b) -> circOnSeg a b p r) - . fmap _wlLine - . IM.filter (not . _wlWalkable) +crOnWall cr = runIdentity + . S.any_ (uncurry (circOnSeg' p r) . _wlLine) + . S.filter (not . _wlWalkable) . wallsNearPoint p where p = _crPos cr diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index 8c98a13ab..b822f3c19 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -91,5 +91,6 @@ makeExplosionAt p w = w newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times addFlames w' = foldl' (flip ($)) w' newFs --pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q wls - pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls - wls = wallsNearPoint p w + --pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls + pushAgainstWalls q = maybe q fst $ reflectPointWallsDamp (const True) 1 p q w +-- wls = wallsNearPoint p w diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index d744afaa0..1752990dd 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -12,6 +12,7 @@ import Geometry import Picture import LensHelp +import Data.Foldable import qualified Data.IntMap.Strict as IM -- currently very effective against walls makeShockwaveAt @@ -62,9 +63,9 @@ mvShockwave is w pt tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt) rad = r - (3/4) * r * tFraction doDams = over creatures (IM.map damCr) - . flip (IM.foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))) + . flip (foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))) hitBlocks - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w damCr cr | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr | otherwise = cr & crState . csDamage .:~ @@ -104,7 +105,7 @@ moveInverseShockwave w pt t = _ptTimer pt rad = r - 0.1 * r * fromIntegral (10 - t) dams = over creatures (IM.map damCr) . flip (foldr (damageBlocksBy 1)) hitBlocks - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w damCr cr | dist (_crPos cr) p >= rad + _crRad cr = cr | otherwise = cr & crState . csDamage .:~ diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index d2404c009..a0aeb98bb 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -206,7 +206,7 @@ damageInArea crt wlt pt w = damwls damcrs where p = _ptPos pt damcrs = foldl' (flip $ \cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w - damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w + damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ filter wlt $ wallsNearPoint' p w hiteff = _ptHitEff pt pt -- | At writing the radius is half the size of the effect area diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index f2e2f3dfe..f417c4401 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -2,6 +2,7 @@ module Dodge.Zone ( crZoneOfPoint , zoneOfLineIntMap , wallsNearPoint + , wallsNearPoint' , wallsAlongLine , zoneSize , zoneOfPoint @@ -187,13 +188,20 @@ wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) Just val -> val _ -> IM.empty -wallsNearPoint :: Point2 -> World -> IM.IntMap Wall -wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] - where +wallsNearPoint' :: Point2 -> World -> [Wall] +wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p + +wallsNearPoint :: Point2 -> World -> Stream (Of Wall) Identity () +wallsNearPoint p w = S.concat $ S.mapMaybe f $ S.each [V2 a b | a <- [x-1,x,x+1], b <- [y-1,y,y+1]] + where (x,y) = zoneOfPoint p - f i m = case IM.lookup i m of - Just val -> val - _ -> IM.empty + f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j +-- IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] +-- where +-- (x,y) = zoneOfPoint p +-- f i m = case IM.lookup i m of +-- Just val -> val +-- _ -> IM.empty flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a flattenIMIMIM = IM.unions . fmap IM.unions diff --git a/src/Geometry.hs b/src/Geometry.hs index d4d2ca7c1..997b1b85f 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -81,6 +81,16 @@ circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) where thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) +-- | Test whether a circle is on a segment by intersecting a normal and testing +-- the distance to the endpoints of the segment. +-- Perhaps a better order of arguments. +circOnSeg' :: Point2 -> Float -> Point2 -> Point2 -> Bool +{-# INLINE circOnSeg' #-} +circOnSeg' !c !rad !p1 !p2 = magV (p1 -.- c) <= rad + || magV (p2 -.- c) <= rad + || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) + where + thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) -- | Test whether a circle is on a segment by intersecting a normal and testing -- the distance to the endpoints of the segment.