diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 38e2240ee..1ab9fe30d 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -37,7 +37,6 @@ module Dodge.Base.Collide ( collide3, ) where -import Linear import Control.Lens import Control.Monad import qualified Data.IntSet as IS @@ -50,24 +49,28 @@ import Dodge.Data.World import Dodge.Zoning import FoldableHelp import Geometry +import Linear collidePoint :: Point2 -> Point2 -> [Wall] -> (Point2, Maybe Wall) {-# INLINE collidePoint #-} collidePoint sp ep = foldl' f (ep, Nothing) where - f (p, mwl) wl - = maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl + f (p, mwl) wl = + maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl overlapSegCrs :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)] {-# INLINE overlapSegCrs #-} -overlapSegCrs sp ep = - mapMaybe - (\cr -> (,cr) <$> fst (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)) +overlapSegCrs sp ep = mapMaybe f + where + f cr = + (,cr) + <$> fst (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep) doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2) {-# INLINE doBounce #-} -doBounce x sp ep (p, mwl) = - mwl <&> \wl -> +doBounce x sp ep (p, mwl) = fmap f mwl + where + f wl = ( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl))) , reflVelWallDamp x wl (ep -.- sp) ) @@ -82,7 +85,13 @@ doBounce x sp ep (p, mwl) = --{-# INLINE bounceBall #-} --bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r -bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2, Point2) +bouncePoint :: + (Wall -> Bool) -> + Float -> + Point2 -> + Point2 -> + World -> + Maybe (Point2, Point2) {-# INLINE bouncePoint #-} bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilter t sp ep @@ -152,19 +161,21 @@ collide3Wall sp wl (ep, mo) = maybe (ep, mo) (,Just (n, OWall wl)) $ intersectSe collide3Creature :: Point3 -> Creature -> (Point3, MPO) -> (Point3, MPO) collide3Creature sp cr (ep, m) = fromMaybe (ep, m) $ do - h <- crHeight cr - (p,n) <- fst $ intersectCylSeg - (cr ^. crPos) - (crRad $ cr ^. crType) - h - sp - ep - return (p, Just (n,OCreature cr)) + h <- crHeight cr + (p, n) <- + fst $ + intersectCylSeg + (cr ^. crPos) + (crRad $ cr ^. crType) + h + sp + ep + return (p, Just (n, OCreature cr)) crHeight :: Creature -> Maybe Float crHeight cr = case cr ^. crHP of - HP {} -> Just 25 - CrIsCorpse {} -> Just 5 + HP{} -> Just 25 + CrIsCorpse{} -> Just 5 CrIsGibs -> Nothing CrIsPitted -> Nothing diff --git a/src/Dodge/Projectile/Update.hs b/src/Dodge/Projectile/Update.hs index 0c0d0fb07..4263361f0 100644 --- a/src/Dodge/Projectile/Update.hs +++ b/src/Dodge/Projectile/Update.hs @@ -3,10 +3,6 @@ module Dodge.Projectile.Update (updateProjectile) where import Linear -import Dodge.Render.List -import Dodge.Render.Label -import ShortShow -import Picture.Base import Control.Monad import Data.List (delete) import Data.Maybe @@ -123,42 +119,6 @@ shellHitFloor p pj w | abs x < 0.01 = 0 | otherwise = x * 0.9 ------- note this doesn't take into account moving walls, which may break the ------- bouncing in some way ---tryShellBounce :: Point3 -> (Point3, Object ) -> Projectile -> World -> World ---tryShellBounce p' (n, OWall wl) pj w --- | Just GStick <- pj ^? pjType . gnHitEffect = --- w --- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjType --- .~ Grenade (GStuckWall (wl ^. wlStructure)) --- & soundOriginIDsAt (ShellSound (pj ^. pjID)) [slapS, slap1S] (pj ^. pjPos . _xy) --- | Just x <- pj ^? pjType . gnHitEffect . bounceTolerance --- , abs (dotV (pj ^. pjVel . _xy) (vNormal hitline)) < x = --- w --- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjVel . _xy --- %~ reflectIn hitline --- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjPos --- .~ p - normalizeV (pj ^. pjVel) --- & soundStart (ShellSound (pj ^. pjID)) (pj ^. pjPos) click1S Nothing --- where --- p = xyV3 p' --- hitline = normalizeV $ uncurry (-) $ _wlLine wl ---tryShellBounce p' (n,OCreature cr) pj w --- | Just GStick <- pj ^? pjType . gnHitEffect = --- w --- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjType --- .~ Grenade --- ( GStuckCreature --- (cr ^. crID) --- (rotate3z (- cr ^. crDir) (p' - ((cr ^. crPos)`v2z`0))) --- (pj ^. pjDir - cr ^. crDir) --- ) --- & soundOriginIDsAt (ShellSound (pj ^. pjID)) [slapS, slap1S] (pj ^. pjPos) --- where --- p = xyV3 p' ---tryShellBounce _ _ pj w = w ---tryShellBounce _ _ pj w = explodeShell pj w - destroyProjectile :: Maybe (NewInt ItmInt) -> Int -> World -> World destroyProjectile mitid pjid w = w & cWorld . lWorld . projectiles %~ IM.delete pjid @@ -260,18 +220,7 @@ moveStuckGrenade cid poff d pj w w & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjType .~ Grenade GStick moveProjectile :: Projectile -> World -> World -moveProjectile pj w = moveProjectile' pj w - & cWorld . lWorld . flares <>~ - (setLayer DebugLayer - $ color red $ line [p, (p +v)] - ) - where - p = pj^. pjPos . _xy - v = pj^. pjVel . _xy - - -moveProjectile' :: Projectile -> World -> World -moveProjectile' pj w +moveProjectile pj w | Just GStuckWall{} <- pj ^? pjType . gnHitEffect = w | Just (GStuckCreature crid poff d) <- pj ^? pjType . gnHitEffect = moveStuckGrenade crid poff d pj w @@ -281,7 +230,6 @@ moveProjectile' pj w shellHitFloor p pj w | (p, Just (_, OCreature cr)) <- collide3 sp (sp + 2 *^ _pjVel pj) w = shellHitCreature p cr pj w - & cWorld . lWorld . flares <>~ test p cr w sp (_pjVel pj) | (_, Just (_, OChasmWall)) <- collide3 sp (sp + 2 *^_pjVel pj) w = -- no stick or bounce for now w & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjTimer .~ 0 @@ -293,31 +241,6 @@ moveProjectile' pj w where sp = _pjPos pj -test :: Point3 -> Creature -> World -> Point3 -> Point3 -> Picture -test p cr w sp v = - (setLayer FixedCoordLayer - $ uncurryV translate (worldPosToScreen (w ^. wCam) (p ^. _xy)) - $ drawList [text (shortShow p),text $ shortShow sp, text $ shortShow $ sp + 2*v, text $ shortShow v] - <> color white (crossPic 5) - ) <> - (setLayer DebugLayer - $ uncurryV translate (p ^. _xy) - $ ( scale 0.1 0.1 - $ stackPicturesAt - [ text $ shortShow p - , text $ shortShow sp - , text $ shortShow (sp + v) - ] - ) <> color green (crossPic 5) - ) <> - setLayer DebugLayer - (uncurryV translate (cr ^. crPos . _xy) - $ circle 10 - ) <> - (setLayer DebugLayer - $ color red $ line [sp^. _xy, (sp +v)^._xy] - ) - explodeShell :: Projectile -> World -> World explodeShell pj w = w