diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 03f4237b5..af976a5d5 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -11,33 +11,22 @@ - -} module Dodge.Base.Collide ( collidePoint + , collideSegCrs , collidePointWallsFilterStream , collidePointTestFilter , overlapSegWalls + , overlapSegCrs + , overlap1SegCrs , bounceBall , bouncePoint , sortStreamOn , minStreamOn --- , wallsOnCirc --- , wallsOnCirc' - , wallsOnLineHit , collideCircWallsStream - , collideCircWalls , circOnSomeWall - , collidePointWallsNorm - , collidePointWalls' + , circOnAnyCr , overlapCircWalls , overlapCircWallsClosest - , collideCircCrsPoint - , collideCircCreatures - , collidePointCreatures - , collidePointAnyWallsReflect , crsNearPoint - , crsOnLine - , crsOnThickLine - , nearestCrInRad - , nearestCrInTri - , nearestCrInFront , allVisibleWalls , hasLOS @@ -51,103 +40,111 @@ import Dodge.Data import Dodge.Zone import Dodge.Base.Wall import Geometry -import FoldableHelp import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens import Control.Monad ---import qualified FoldlHelp as L -import Data.Monoid import StreamingHelp import qualified Streaming.Prelude as S collidePoint :: Point2 -> Point2 - -> Stream (Of Wall) Identity () + -> StreamOf Wall -> (Point2, Maybe Wall) {-# INLINE collidePoint #-} collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id where findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl +overlap1SegCrs :: Point2 -> Point2 + -> StreamOf Creature + -> StreamOf (Point2, Creature) +{-# INLINE overlap1SegCrs #-} +overlap1SegCrs sp ep = S.mapMaybe + (\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep )) + +overlapSegCrs :: Point2 -> Point2 + -> StreamOf Creature + -> StreamOf ([Point2], Creature) +{-# INLINE overlapSegCrs #-} +overlapSegCrs sp ep = S.mapMaybe + (\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep ) + where + f _ [] = Nothing + f cr ps = Just (ps,cr) + +collideSegCrs :: Point2 -> Point2 + -> StreamOf Creature + -> (Point2, Maybe Creature) +{-# INLINE collideSegCrs #-} +collideSegCrs sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id + where + findPoint (p,mcr) cr + = maybe (p,mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p) + doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2) +{-# INLINE doBounce #-} doBounce x sp ep (p, mwl) = mwl <&> \wl -> ( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl))) , reflVelWallDamp x wl (ep -.- sp) ) bounceBall :: Float -> Point2 -> Point2 -> Float - -> Stream (Of Wall) Identity () + -> StreamOf Wall -> Maybe (Point2,Point2) +{-# INLINE bounceBall #-} bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2) +{-# INLINE bouncePoint #-} bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep -- this COULD be written in terms of collidePointWallsFilterStream, TODO test -- whether this is actually faster -collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool +collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool +{-# INLINE collidePointTestFilter #-} collidePointTestFilter t sp ep = runIdentity . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) . S.filter t collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall) +{-# INLINE collidePointWallsFilterStream #-} collidePointWallsFilterStream t sp ep = collidePoint sp ep . S.filter t . wlsNearSeg sp ep -overlapSegWalls :: Point2 -> Point2 -> Stream (Of Wall) Identity () - -> Stream (Of (Point2,Wall)) Identity () +overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall + -> StreamOf (Point2,Wall) +{-# INLINE overlapSegWalls #-} overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl) -visibleWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity () +visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall) +{-# INLINE visibleWalls #-} visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap ( S.span (not . wlIsOpaque . snd) . sortStreamOn (dist sp . fst) . overlapSegWalls sp ep . wlsNearSeg sp ep ) -allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity () +allVisibleWalls :: World -> StreamOf (Point2,Wall) +{-# INLINE allVisibleWalls #-} allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20) where vPos = _cameraViewFrom w - -wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall) -wallsOnLineHit p1 p2 = IM.mapMaybe f - where - f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl) - --- | 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 -collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) -collidePointAnyWallsReflect p1 p2 - = getFirst - . foldMap (First . findPoint . _wlLine) - where - findPoint (x,y) = case intersectSegSeg p1 p2 x y of - Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1)) - Nothing -> Nothing - -collidePointWalls' :: (Foldable t, Functor t) => Point2 -> Point2 -> t Wall -> Point2 -{-# INLINE collidePointWalls' #-} -collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine - where - findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) - -overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity () - -> Stream (Of (Point2,Wall)) Identity () +overlapCircWalls :: Point2 -> Float -> StreamOf Wall + -> StreamOf (Point2,Wall) +{-# INLINE overlapCircWalls #-} 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 --- note that this does not push the circle away from the wall at all -collideCircWallsStream :: Point2 -> Point2 -> Float -> Stream (Of Wall) Identity () +-- | note that this does not push the circle away from the wall at all +collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall -> (Point2, Maybe Wall) -collideCircWallsStream sp ep rad = runIdentity - . S.fold_ findPoint (ep, Nothing) id +{-# INLINE collideCircWallsStream #-} +collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing) id where findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . shiftbyrad @@ -157,142 +154,24 @@ collideCircWallsStream sp ep rad = runIdentity ,b +.+ rad *.* normalizeV (b -.-a) ) where - f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) + f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b)) -overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall) +overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall) +{-# INLINE overlapCircWallsClosest #-} overlapCircWallsClosest p r = minStreamOn (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) -collideCircWalls p1 p2 rad - = safeMinimumOn (dist p1 . fst) - . IM.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) - ] --- this shifts the wall out, and for outer corners extends the wall --- not sure what this does for inner corners, hopefully won't cause a problem --- the alternative would be to separately bounce off corner points... --- unfortunately, doesn't allow for collisions when the circle spawns on the --- wall - - --- | Looks for first collision of a point with walls. --- If found, gives point and normal of wall. -collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) -collidePointWallsNorm p1 p2 ws - = safeMinimumOn (dist p1 . fst) - $ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) - . _wlLine) ws --- | Returns the first creature, if any, that a point intersects with. -collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int -collidePointCreatures p1 p2 = fmap fst - . safeMinimumOn snd - . IM.toList - . IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2) --- | As for 'collidePointCreatures', only increases the radius of creatures by a ---fixed amount, thus collides a moving circle with creaures. -collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int -collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad) - --- | Returns the first creature id, if any, that a point intersects with, gives point ---in creature on line. -collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int) -collidePointCrsPoint p1 p2 = fmap f - . safeMinimumOn (dist p1 . snd) - . IM.toList - . IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2) - where - f (cID,p) = (p,cID) -{- | Finds the first creature hit on a line. -Maybe evaluates the creature id and hit point. -} -collideCircCrsPoint :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe (Point2,Int) -collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad) - ----- | Makes a creature not hittable. ---collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int) ---collidePointCrsWithoutPoint cid p1 p2 w --- = fmap f --- . safeMinimumOn (snd . snd) --- . IM.toList --- . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x)) --- . IM.delete cid --- $ _creatures w --- where --- f (cID,(p,_)) = (p,cID) {- | Test if a circle collides with any wall. - Note no check on whether the wall is walkable. -} circOnSomeWall :: Point2 -> Float -> World -> Bool +{-# INLINE circOnSomeWall #-} circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine) . wlsNearPoint p --- = any (\(x,y) -> circOnSeg x y p rad) --- . fmap _wlLine --- . IM.elems --- . wallsNearPoint p -{- | Produce an unordered list of creatures on a line. -} -crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature -crsOnLine p1 p2 - = 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 -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness)) - . _creatures -{- | Find 'Maybe' the closest creature to a point, within a circle. - -} -nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature -nearestCrInRad p r - = safeMinimumOn (dist p . _crPos) - . IM.filter (\cr -> dist p (_crPos cr) < r) - . _creatures -{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape. -} -nearestCrInTri - :: Point2 - -> Float -- ^ Direction (radians +ve anticlockwise from x-axis). - -> Float -- ^ Distance. - -> World -> Maybe Creature -nearestCrInTri p dir x - = safeMinimumOn (dist p . _crPos) - . IM.filter (\cr -> pointInPolygon (_crPos cr) tri) - . _creatures - where - tri = - [p - ,p +.+ rotateV (dir-pi/4) (V2 x 0) - ,p +.+ rotateV (dir+pi/4) (V2 x 0) - ] -{- | Find 'Maybe' the closes creature in front of a point in a given direction for -a given distance. -The shapes within which creatures are searched are a triangle then rectangle. -} -nearestCrInFront - :: Point2 - -> Float -- ^ Direction (radians +ve anticlockwise from x-axis). - -> Float -- ^ Distance. - -> World -> Maybe Creature -nearestCrInFront p dir x - = safeMinimumOn (dist p . _crPos) - . IM.filter (\cr -> pointInPolygon (_crPos cr) rec) - . _creatures - where - rec = [p, pR, pR1, pL1, pL ] - pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0) - pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0) - pR1 = pR +.+ rotateV dir (V2 (x/2) 0) - pL1 = pL +.+ rotateV dir (V2 (x/2) 0) +circOnAnyCr :: Point2 -> Float -> World -> Bool +{-# INLINE circOnAnyCr #-} +circOnAnyCr p r = runIdentity . S.any_ (\cr -> dist p (_crPos cr) < r + _crRad cr) + . crsNearPoint p {- | More general collision tests follow -} @@ -309,22 +188,26 @@ hasButtonLOS p1 p2 = not . wlsNearSeg p1 p2 hasLOSIndirect :: Point2 -> Point2 -> World -> Bool +{-# INLINE hasLOSIndirect #-} hasLOSIndirect p1 p2 = not . collidePointTestFilter wlIsOpaque p1 p2 . wlsNearSeg p1 p2 isWalkable :: Point2 -> Point2 -> World -> Bool +{-# INLINE isWalkable #-} isWalkable p1 p2 = not . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 . wlsNearSeg p1 p2 canSee :: Int -> Int -> World -> Bool +{-# INLINE canSee #-} canSee i j w = hasLOS p1 p2 w where p1 = _crPos (_creatures w IM.! i) p2 = _crPos (_creatures w IM.! j) canSeeIndirect :: Int -> Int -> World -> Bool +{-# INLINE canSeeIndirect #-} canSeeIndirect i j w = hasLOSIndirect ipos jpos w where ipos = _crPos (_creatures w IM.! i) diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 971624c7c..fd1a17562 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -28,6 +28,7 @@ import qualified IntMapHelp as IM import ShapePicture import Shape +import qualified Streaming.Prelude as S --import qualified Data.Set as S import qualified Data.Map.Strict as M import qualified SDL @@ -332,9 +333,9 @@ moveRemoteShell cid itid pj w doExplosion = explodeRemoteRocket itid i $ stopSoundFrom (ShellSound i) w anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool -anythingHitCirc rad sp ep w = isJust hitCr || isJust (sequence hitWl) +anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl) where - hitCr = collideCircCrsPoint sp ep rad (_creatures w) + hitCr = runIdentity $ S.any_ (const True) $ overlap1SegCrs sp ep $ crsNearSeg sp ep w hitWl = collideCircWallsStream sp ep rad $ wlsNearPoint ep w -- this should probably be wallsOnLine or something