diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 6e0bed495..c59205130 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -27,8 +27,8 @@ module Dodge.Base.Collide , collidePointWalls' -- , collidePointWallsL , collidePointWallsFilt - , overlapCircWallsReturnWall - , overlapCircWallsReturnWall' + , overlapCircWalls + , overlapCircWallsClosest , collideCircCrsPoint , collideCircCreatures , collidePointCreatures @@ -49,6 +49,7 @@ import FoldableHelp --import Data.List import Data.Maybe +import Data.Function (on) import qualified Data.IntMap.Strict as IM import Control.Lens import Control.Monad @@ -234,30 +235,10 @@ wallsOnLineHit p1 p2 = IM.mapMaybe f f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl) wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall -wallsOnCirc p r = IM.filter f - where - f wl = uncurry circOnSeg (_wlLine wl) p r +wallsOnCirc p r = IM.filter (uncurry (circOnSeg p r) . _wlLine) 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 -overlapCircWallsReturnWall p rad - = L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine)) - 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 +wallsOnCirc' p r = filter $ uncurry (circOnSeg p r) . _wlLine -- | Looks for any collision of a circle with walls. -- If found, gives point and reflection velocity, reflection damped in normal. @@ -332,6 +313,18 @@ collideCircWallsList p1 p2 rad ,b +.+ rad *.* normalizeV (b -.-a) ] +overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity () + -> Stream (Of (Point2,Wall)) Identity () +overlapCircWalls p r = S.mapMaybe dointersect + where + dointersect wl = f (_wlLine wl) <&> (,wl) + f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) a b + +overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall) +overlapCircWallsClosest p r = runIdentity + . L.purely S.fold_ (L.minimumBy (compare `on` (dist p . fst))) + . overlapCircWalls p r + -- | Looks for first collision of a circle with walls. -- If found, gives point and reflection velocity, reflection damped in normal. collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2) @@ -414,7 +407,7 @@ 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 = runIdentity . S.any_ (uncurry (circOnSeg' p rad) . _wlLine) +circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine) . wallsNearPoint p -- = any (\(x,y) -> circOnSeg x y p rad) -- . fmap _wlLine @@ -427,12 +420,12 @@ crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures {- | Produce an unordered list of creatures on a line. -} crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature crsOnLine p1 p2 - = IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr)) + = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr)) . _creatures {- | Produce an unordered list of creatures on a wide line. -} crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature crsOnThickLine thickness p1 p2 - = IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness)) + = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness)) . _creatures {- | Find 'Maybe' the closest creature to a point, within a circle. -} diff --git a/src/Dodge/Beam.hs b/src/Dodge/Beam.hs index 39054a268..ec9742a1c 100644 --- a/src/Dodge/Beam.hs +++ b/src/Dodge/Beam.hs @@ -10,7 +10,7 @@ import Geometry import LensHelp import Picture import RandomHelp -import Dodge.Zone +--import Dodge.Zone import Dodge.Base.Collide import Shape @@ -114,7 +114,6 @@ defaultArcStep itparams w (ArcStep p dir _) = do . filter (\cr -> dist center (_crPos cr) < csize) . IM.elems $ _creatures w - wlsnearpoint = wallsNearPoint' p w mwl = listToMaybe . sortOn (dist p . fst) . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w) diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index a6712c29e..37e83dab1 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -479,12 +479,12 @@ updateTractor pj w tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem tractFlIt q p1 outpos it - | circOnSeg p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1 + | segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1 | otherwise = it tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature tractCr q p1 outpos cr - | circOnSeg p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1 + | segOnCirc p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1 | otherwise = cr tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2 diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 53d4b80b2..fcb66dd57 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -58,7 +58,7 @@ drawOptions u title ops off footer = pictures $ , drawFooterText cfig red footer ] ++ zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s) - (ops'') + ops'' [hh-100,hh-150 ..] -- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] | -- y <- map (+75) [0,50..hh*2]] diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 05f566f08..04dbddbdf 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -142,10 +142,18 @@ ifConfigWallRotate cfig w | otherwise = w rotateToOverlappingWall :: World -> World -rotateToOverlappingWall w = maybe w dowallrotate - $ overlapCircWallsReturnWall' p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w) +rotateToOverlappingWall w = maybe + id + (doWallRotate . snd) + (overlapCircWallsClosest p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w)) + w + where + cr = you w + p = _crPos (you w) + +doWallRotate :: Wall -> World -> World +doWallRotate wl' w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w where - dowallrotate wl' = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w rotateUsing a | b - b' > 0.01 = w & cameraRot +~ 0.01 | b - b' < negate 0.01 = w & cameraRot -~ 0.01 @@ -154,8 +162,6 @@ rotateToOverlappingWall w = maybe w dowallrotate --b = a * (2 / pi) b = a * (4 / pi) b' = fromIntegral (round b :: Int) - cr = you w - p = _crPos cr rotateCameraBy :: Float -> World -> World rotateCameraBy x w = w diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 321b5c2b5..2b88015db 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -16,7 +16,7 @@ import Data.Monoid import Data.Maybe import Data.Function import Control.Lens -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM import qualified Streaming.Prelude as S @@ -84,7 +84,7 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of -- note the inclusion of endpoints in circOnSeg crOnWall :: Creature -> World -> Bool crOnWall cr = runIdentity - . S.any_ (uncurry (circOnSeg' p r) . _wlLine) + . S.any_ (uncurry (circOnSeg p r) . _wlLine) . S.filter (not . _wlWalkable) . wallsNearPoint p where diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index b822f3c19..8134b3716 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -10,7 +10,7 @@ module Dodge.WorldEvent.Explosion import Dodge.Data import Dodge.LightSource --import Dodge.Default -import Dodge.Zone +--import Dodge.Zone import Dodge.Base.Collide import Dodge.WorldEvent.SpawnParticle --import Dodge.WorldEvent.Flash diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index 1752990dd..87e4e3c11 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -12,8 +12,9 @@ import Geometry import Picture import LensHelp -import Data.Foldable +--import Data.Foldable import qualified Data.IntMap.Strict as IM +import qualified Streaming.Prelude as S -- currently very effective against walls makeShockwaveAt :: [Int] -- ^ IDs of invulnerable creatures. @@ -52,7 +53,7 @@ mvShockwave :: [Int] -- ^ IDs of invulnerable creatures. -> World -> Particle -> (World, Maybe Particle) mvShockwave is w pt - | _ptTimer pt <= 0 = ( w , Nothing) + | _ptTimer pt <= 0 = ( w , Nothing) | otherwise = (doDams w , Just $ pt & ptTimer -~ 1) where r = _ptRad pt @@ -62,10 +63,15 @@ mvShockwave is w pt t = _ptTimer pt tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt) rad = r - (3/4) * r * tFraction - doDams = over creatures (IM.map damCr) - . flip (foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))) - hitBlocks - hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w + doDams w' = over creatures (IM.map damCr) + . runIdentity + $ S.fold_ + (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect)) + w' + id + hitBlocks + hitBlocks = S.map snd . overlapCircWalls p rad $ wallsAlongCirc' p rad w + -- this is not expansive enough damCr cr | _crID cr `elem` is || 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 a0aeb98bb..b38dd8582 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -96,7 +96,7 @@ moveFlame rotd w pt , _ptCrIgnore = Nothing , _ptVel = speed *.* vel } dodamage = damageInArea closeCrs closeWls pt - closeWls wl = uncurry circOnSeg (_wlLine wl) ep 5 + closeWls wl = uncurry segOnCirc (_wlLine wl) ep 5 closeCrs cr = dist ep (_crPos cr) < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) @@ -197,7 +197,7 @@ damageInRadius :: Float -> Particle -> World -> World damageInRadius size pt = damageInArea isClose closeWls pt where p = _ptPos pt - closeWls wl = uncurry circOnSeg (_wlLine wl) p size + closeWls wl = uncurry segOnCirc (_wlLine wl) p size isClose cr = dist p (_crPos cr) < _crRad cr + size damageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Particle -> World -> World diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index f417c4401..9eb94655f 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -7,6 +7,7 @@ module Dodge.Zone , zoneSize , zoneOfPoint , wallsAlongCirc + , wallsAlongCirc' , wallsOnScreen , lookLookups , zoneAroundPoint @@ -92,6 +93,8 @@ zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet --zoneOfLineIntMap = ddaExt zoneSize zoneOfLineIntMap = ddaSq zoneSize +zoneOfCirc p = S.map (uncurry V2) . S.each . zoneOfCircle p + zoneOfCircle :: Point2 -> Float -> [(Int,Int)] zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r @@ -188,6 +191,11 @@ wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) Just val -> val _ -> IM.empty +wallsAlongCirc' :: Point2 -> Float -> World -> Stream (Of Wall) Identity () +wallsAlongCirc' p r w = S.concat $ S.mapMaybe f $ zoneOfCirc p r + where + f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j + wallsNearPoint' :: Point2 -> World -> [Wall] wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p diff --git a/src/Geometry.hs b/src/Geometry.hs index 997b1b85f..4f552c3a8 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -84,19 +84,19 @@ circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenorma -- | 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 +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 +-- | Test whether a segment intersects a circle by intersecting a normal and testing -- the distance to the endpoints of the segment. -circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool -{-# INLINE circOnSeg #-} -circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad +segOnCirc :: Point2 -> Point2 -> Point2 -> Float -> Bool +{-# INLINE segOnCirc #-} +segOnCirc !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) where