Cleanup, move towards explosions at different z positions

2025-08-04 22:13:45 +01:00
parent 7714e2e298
commit bde0fa2a5c
4 changed files with 221 additions and 178 deletions
@@ -18,7 +18,7 @@ module Dodge.Base.Collide (
    collideCircWalls,
    overlapSegWalls,
    overlapSegCrs,
--    bounceBall,
+    --    bounceBall,
    bouncePoint,
    circOnSomeWall,
    circOnAnyCr,
@@ -37,14 +37,14 @@ module Dodge.Base.Collide (
    collide3,
 ) where

-import Dodge.Data.Object
-import Control.Monad
-import Dodge.Creature.Radius
 import Control.Lens
+import Control.Monad
 import qualified Data.IntSet as IS
 import Data.List (sortOn)
 import Data.Maybe
 import Dodge.Base.Wall
+import Dodge.Creature.Radius
+import Dodge.Data.Object
 import Dodge.Data.World
 import Dodge.Zoning
 import FoldableHelp
@@ -85,63 +85,95 @@ bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Po
 {-# INLINE bouncePoint #-}
 bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilter t sp ep

-type MPO = Maybe (Point3,Object)
+type MPO = Maybe (Point3, Object)

 collide3WallsFloor :: Point3 -> Point3 -> World -> (Point3, MPO)
-collide3WallsFloor sp ep w = collide3Floors sp (w ^. cWorld . chasms) 
-    $ collide3Walls sp w (ep,Nothing)
+collide3WallsFloor sp ep w =
+    collide3Floors sp (w ^. cWorld . chasms) $
+        collide3Walls sp w (ep, Nothing)

-collide3 :: Point3 -> Point3 -> World -> (Point3,MPO)
-collide3 sp ep w = foldl' (flip $ collide3Creature sp) (p,m) 
-    $ crsNearSeg (xyV3 sp) (xyV3 p) w
+-- could check the line is at least below z=0 at some point
+collide3Chasms :: Point3 -> World -> (Point3, MPO) -> (Point3, MPO)
+collide3Chasms sp w m =
+    foldl'
+        (flip (collide3Chasm sp))
+        m
+        (foldMap loopPairs $ w ^. cWorld . chasms)
+
+collide3Chasm :: Point3 -> (Point2, Point2) -> (Point3, MPO) -> (Point3, MPO)
+collide3Chasm sp ab (ep, m) =
+    maybe (ep, m) (,Just (n, OChasmWall)) $
+        intersectSegSurface sp ep p n ss
  where
-    (p,m) = collide3WallsFloor sp ep w
+    (p, n, ss) = chasmWallToSurface ab
+
+chasmWallToSurface :: (Point2, Point2) -> (Point3, Point3, [(Point3, Point3)])
+chasmWallToSurface (x, y) =
+    ( g x
+    , g $ vNormal (x - y)
+    , [(g x, g (y - x)), (g y, g (x - y)), (0, V3 0 0 (-1))]
+    )
+  where
+    g = (`v2z` 0)
+
+collide3 :: Point3 -> Point3 -> World -> (Point3, MPO)
+collide3 sp ep w =
+    collide3Chasms sp w
+        . foldl' (flip $ collide3Creature sp) (p, m)
+        $ crsNearSeg (xyV3 sp) (xyV3 p) w
+  where
+    (p, m) = collide3WallsFloor sp ep w

 -- Just (hitpoint,normaltosurface)
 collide3Walls :: Point3 -> World -> (Point3, MPO) -> (Point3, MPO)
-collide3Walls sp w ex@(ep,_) = foldl' f ex wls
+collide3Walls sp w ex@(ep, _) = foldl' f ex wls
  where
    f x wl = collide3Wall sp wl x
    wls = wlsNearSeg (xyV3 sp) (xyV3 ep) w

-collide3Floors :: Point3 -> [[Point2]] -> (Point3, Maybe (Point3,Object))
-    -> (Point3, Maybe (Point3,Object))
-collide3Floors sp cs (ep,mn) = maybe (ep,mn) (,Just (V3 0 0 1,OFloor)) mp
+collide3Floors ::
+    Point3 ->
+    [[Point2]] ->
+    (Point3, Maybe (Point3, Object)) ->
+    (Point3, Maybe (Point3, Object))
+collide3Floors sp cs (ep, mn) = maybe (ep, mn) (,Just (V3 0 0 1, OFloor)) mp
  where
    mp = do
        V3 x y z <- intersectSegPlane sp ep (V3 0 0 0) (V3 0 0 1)
-        let g (a,b) = isRHS a b (V2 x y)
+        let g (a, b) = isRHS a b (V2 x y)
            f = any g
        guard (all (f . loopPairs) cs)
        return $ (V3 x y z)

 collide3Wall :: Point3 -> Wall -> (Point3, MPO) -> (Point3, MPO)
-collide3Wall sp wl (ep,mo) = maybe (ep,mo) (,Just (n,OWall wl)) $ intersectSegSurface sp ep p n ss
+collide3Wall sp wl (ep, mo) = maybe (ep, mo) (,Just (n, OWall wl)) $ intersectSegSurface sp ep p n ss
  where
-    (p,n,ss) = wallToSurface wl
+    (p, n, ss) = wallToSurface wl

 collide3Creature :: Point3 -> Creature -> (Point3, MPO) -> (Point3, MPO)
-collide3Creature sp cr (ep,m) = fromMaybe (ep,m) $ do
-    (sp',ep') <- restrictSeg 0 (V3 0 0 1) (sp,ep) >>= restrictSeg (V3 0 0 25) (V3 0 0 (-1))
+collide3Creature sp cr (ep, m) = fromMaybe (ep, m) $ do
+    (sp', ep') <- restrictSeg 0 (V3 0 0 1) (sp, ep) >>= restrictSeg (V3 0 0 25) (V3 0 0 (-1))
    p <- listToMaybe $ intersectCircSeg cpos (crRad $ cr ^. crType) (xyV3 sp') (xyV3 ep')
    let z = 0
-    return (p `v2z` z,Just (normalize $ (p - cpos) `v2z` 0, OCreature cr))
+    return (p `v2z` z, Just (normalize $ (p - cpos) `v2z` 0, OCreature cr))
  where
    cpos = cr ^. crPos

-restrictSeg :: Point3 -> Point3 -> (Point3,Point3) -> Maybe (Point3,Point3)
-restrictSeg p n (sp,ep)
+restrictSeg :: Point3 -> Point3 -> (Point3, Point3) -> Maybe (Point3, Point3)
+restrictSeg p n (sp, ep)
    | isNHS p n sp
-    , isNHS p n ep = Just (sp,ep)
+      , isNHS p n ep =
+        Just (sp, ep)
    | isNHS p n sp = (sp,) <$> intersectSegPlane sp ep p n
    | otherwise = (,ep) <$> intersectSegPlane sp ep p n
-  -- note if both sp & ep are not NHS, this returns Nothing

-wallToSurface :: Wall -> (Point3,Point3,[(Point3,Point3)])
-wallToSurface wl = (g x, g $ vNormal (x-y), [(g x,g (y-x)),(g y,g (x-y))])
-      where
-        g = (`v2z` 0)
-        (x,y) = _wlLine wl
+-- note if both sp & ep are not NHS, this returns Nothing
+
+wallToSurface :: Wall -> (Point3, Point3, [(Point3, Point3)])
+wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y))])
+  where
+    g = (`v2z` 0)
+    (x, y) = _wlLine wl

 -- this COULD be written in terms of collidePointWallsFilterStream, TODO test
 -- whether this is actually faster
@@ -198,9 +230,11 @@ overlapCircWalls p r = mapMaybe dointersect
    f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b

 circHitWall :: Point2 -> Point2 -> Float -> World -> Bool
-circHitWall sp ep r w = any (uncurry (intersectSegSegTest xsp xep) . _wlLine)
+circHitWall sp ep r w =
+    any
+        (uncurry (intersectSegSegTest xsp xep) . _wlLine)
        (wlsNearSeg xsp xep w)
-    || circOnSomeWall ep r w
+        || circOnSomeWall ep r w
  where
    x = r *.* normalizeV (ep - sp)
    xsp = sp - x
@@ -213,12 +247,17 @@ collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
  where
    findPoint (p, mwl) wl =
        maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
-            . shiftbyrad . _wlLine $ wl
--    shiftbyrad (a, b) =
--            ( a +.+ rad *.* normalizeV (a -.- b)
--            , b +.+ rad *.* normalizeV (b -.- a)
--            )
-    shiftbyrad (a, b) = bimap f f
+            . shiftbyrad
+            . _wlLine
+            $ wl
+    --    shiftbyrad (a, b) =
+    --            ( a +.+ rad *.* normalizeV (a -.- b)
+    --            , b +.+ rad *.* normalizeV (b -.- a)
+    --            )
+    shiftbyrad (a, b) =
+        bimap
+            f
+            f
            ( a +.+ rad *.* normalizeV (a -.- b)
            , b +.+ rad *.* normalizeV (b -.- a)
            )
@@ -262,6 +301,7 @@ hasLOS p1 p2 =
 hasButtonLOS :: Point2 -> Point2 -> World -> Bool
 {-# INLINE hasButtonLOS #-}
 hasButtonLOS _ _ = const True
+
 --hasButtonLOS p1 p2 =
 --    not
 --        . collidePointTestFilter (not . _wlTouchThrough) p1 p2
@@ -64,7 +64,7 @@ shellExplosionCheck pj w
    time = _pjTimer pj

 shellHitWall :: Point3 -> Point3 -> Wall -> Projectile -> World -> World
-shellHitWall p' n wl pj w
+shellHitWall p' _ wl pj w
    | Just GStick <- pj ^? pjType . gnHitEffect =
        w
            & cWorld . lWorld . projectiles . ix (_pjID pj) . pjType
@@ -84,28 +84,27 @@ shellHitWall p' n wl pj w
    p = xyV3 p'
    hitline = normalizeV $ uncurry (-) $ _wlLine wl

-shellHitCreature :: Point3 -> Point3 -> Creature -> Projectile -> World -> World
-shellHitCreature p' n cr pj w
+shellHitCreature :: Point3 -> Creature -> Projectile -> World -> World
+shellHitCreature p 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)))
+                        (rotate3z (- cr ^. crDir) (p - ((cr ^. crPos)`v2z`0)))
                        (pj ^. pjDir - cr ^. crDir)
                    )
            & soundOriginIDsAt (ShellSound (pj ^. pjID)) [slapS, slap1S] (pj ^. pjPos . _xy)
-    | otherwise = w & cWorld . lWorld . projectiles . ix (_pjID pj) . pjPos .~ p'
+    | otherwise = w
            &  cWorld . lWorld . projectiles . ix (_pjID pj) . pjTimer .~ 0
-  where
-    p = xyV3 p'

-shellHitFloor :: Point3 -> Point3 -> Projectile -> World -> World
-shellHitFloor p' n pj w 
+shellHitFloor :: Point3 -> Projectile -> World -> World
+shellHitFloor p' pj w 
    | z < 1 && norm (_pjVel pj) < 1 = w 
    | otherwise = 
-        w & topj . pjPos . _z .~ 0.1
+        w 
+          & topj . pjPos .~ (p' & _z .~ 0.1)
            & topj . pjVel . _z %~ bouncez
            & topj . pjVel . _xy %~ decvel
            & topj . pjSpin %~ decspin
@@ -244,14 +243,9 @@ pjRemoteSetDirection ph pj w = case ph of
  where
    lw = w ^. cWorld . lWorld

-moveStuckGrenade :: Creature -> Point3 -> Float -> Projectile -> World -> World
-moveStuckGrenade cr p d pj w = w
-
-moveProjectile :: Projectile -> World -> World
-moveProjectile pj w
-    | Just GStuckWall{} <- pj ^? pjType . gnHitEffect = w
-    | Just (GStuckCreature crid poff d) <- pj ^? pjType . gnHitEffect
-      , Just cr <- w ^? cWorld . lWorld . creatures . ix crid =
+moveStuckGrenade :: Int -> Point3 -> Float -> Projectile -> World -> World
+moveStuckGrenade cid poff d pj w 
+    | Just cr <- w ^? cWorld . lWorld . creatures . ix cid =
        let cpos = cr ^. crPos
            cdir = cr ^. crDir
            vel = cpos - cr ^. crOldPos
@@ -260,21 +254,30 @@ moveProjectile pj w
                    .~ xyV3 ((cpos `v2z` 0) + rotate3z cdir poff)
                & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjDir .~ d + cdir
                & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjVel . _xy .~ vel
-    | Just GStuckCreature{} <- pj ^? pjType . gnHitEffect =
+    | otherwise =
        w & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjType .~ Grenade GStick
-    | (p,Just (n,OWall wl)) <- collide3 p (p + _pjVel pj) w 
+
+moveProjectile :: Projectile -> World -> World
+moveProjectile pj w
+    | Just GStuckWall{} <- pj ^? pjType . gnHitEffect = w
+    | Just (GStuckCreature crid poff d) <- pj ^? pjType . gnHitEffect
+        = moveStuckGrenade crid poff d pj w
+    | (p,Just (n,OWall wl)) <- collide3 sp (sp + _pjVel pj) w 
        = shellHitWall p n wl pj w
-    | (p,Just (n,OFloor)) <- collide3 p (p + _pjVel pj) w 
-        = shellHitFloor p n pj w
-    | (p,Just (n,OCreature cr)) <- collide3 p (p + _pjVel pj) w 
-        = shellHitCreature p n cr pj w
+    | (p,Just (_,OFloor)) <- collide3 sp (sp + _pjVel pj) w 
+        = shellHitFloor p pj w
+    | (p,Just (_,OCreature cr)) <- collide3 sp (sp + _pjVel pj) w 
+        = shellHitCreature p cr pj w
+    | (_,Just (_,OChasmWall)) <- collide3 sp (sp + _pjVel pj) w 
+        -- no stick or bounce for now
+        = w & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjTimer .~ 0
    | otherwise =
        w
            & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjSpin *~ 0.99
            & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjPos +~ _pjVel pj
            & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjDir +~ _pjSpin pj
  where
-    p = _pjPos pj
+    sp = _pjPos pj

 explodeShell :: Projectile -> World -> World
 explodeShell pj w =
@@ -71,7 +71,7 @@ makeFlameExplosionAt p w =
 makeExplosionAt :: Point2 -> Point2 -> World -> World
 makeExplosionAt p vel w =
    w
-        & soundStart (Explosion (w ^. cWorld . lWorld . lClock)) p bangS Nothing
+        & soundStart (Explosion (w ^. cWorld . lWorld . lClock)) (p) bangS Nothing
        & addFlames
        & cWorld . lWorld . worldEvents 
            .:~ MakeTempLight (LSParam (addZ 20 p) 150 (V3 1 0.5 0)) 20