From 941fef134de59685c51bbee77164995d565bc400 Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 23 Mar 2021 12:06:46 +0100 Subject: [PATCH] Implement wall penetrating bullets --- src/Dodge/Item/Weapon.hs | 14 ++++---- src/Dodge/Item/Weapon/Bullet.hs | 4 +-- src/Dodge/LevelGen/Block.hs | 4 +-- src/Dodge/LevelGen/WindowBlock.hs | 59 ++----------------------------- src/Dodge/WorldEvent.hs | 59 ++++++++++++++++++++++--------- src/Dodge/WorldEvent/Bullet.hs | 15 ++++---- src/Picture/Render.hs | 2 ++ 7 files changed, 67 insertions(+), 90 deletions(-) diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 29d829c0d..b297546dc 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -64,7 +64,7 @@ pistol = Weapon . withRandomDir 0.1 . withMuzFlare . withVelWthHiteff (30,0) 2 - $ threeEff' bulHitCr' bulHitWall' bulHitFF' + $ destroyOnImpact bulHitCr' bulHitWall' bulHitFF' , _wpSpread = 0.02 , _wpRange = 20 , _itHammer = HammerUp @@ -130,14 +130,14 @@ autoFireMode = shootWithSound (fromIntegral autoGunSound) . withRandomDir (autogunSpread/2) . withMuzFlare . withVelWthHiteff (50,0) 3 - $ threeEff' bulHitCr' bulHitWall' bulHitFF' + $ destroyOnImpact bulHitCr' bulHitWall' bulHitFF' singleFireMode = shootWithSound (fromIntegral autoGunSound) . withRecoil 40 . torqueAfter 0.03 . withRandomDir (autogunSpread/2) . withMuzFlare . withVelWthHiteff (50,0) 3 - $ threeEff' bulHitCr' bulHitWall' bulHitFF' + $ destroyOnImpact bulHitCr' bulHitWall' bulHitFF' incMode :: Int -> World -> World incMode _ w @@ -373,7 +373,7 @@ mkBezierBul :: Point2 -> Point2 -> Point2 -> Int -> World -> World mkBezierBul startp controlp targetp cid w = over particles' (bbul :) w where bbul = aCurveBulAt (Just cid) white startp (controlp +.+ randPos) (targetp +.+ randPos') - (threeEff' bulHitCr' bulHitWall' bulHitFF') 5 + (destroyOnImpact bulHitCr' bulHitWall' bulHitFF') 5 (randPos,randPos') = flip evalState (_randGen w) $ do a <- randInCirc 10 b <- randInCirc 20 @@ -428,7 +428,7 @@ hvAutoGun = defaultAutoGun . withThinSmoke . withMuzFlare . withVelWthHiteff (80,0) 6 - $ threeEff' + $ penWalls hvBulHitCr' hvBulHitWall' bulHitFF' ltAutoGun = defaultAutoGun @@ -567,7 +567,7 @@ longGun = defaultGun . torqueAfter 0.05 . withMuzFlare . withVelWthHiteff (60,0) 6 - $ threeEff' hvBulHitCr' hvBulHitWall' bulHitFF' + $ penWalls hvBulHitCr' hvBulHitWall' bulHitFF' , _wpSpread = 0.0 , _wpRange = 200 @@ -895,7 +895,7 @@ makeFlame pos vel maycid = over particles' ((:) theFlame) , _btPassThrough' = maycid , _btWidth' = 4 , _btTimer' = 100 - , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff } moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle') diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index fd5a997e0..09eed9c81 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -218,10 +218,10 @@ bulHitFF' :: Particle' -> Point2 -> ForceField -> World -> World bulHitFF' _ _ _ = id bulletEffect' :: HitEffect -bulletEffect' = threeEff' bulHitCr' bulHitWall' bulHitFF' +bulletEffect' = destroyOnImpact bulHitCr' bulHitWall' bulHitFF' bulletParticleSideEffect :: Particle' -> HitEffect -bulletParticleSideEffect pt = threeEff' mkPt mkPt noEff +bulletParticleSideEffect pt = destroyOnImpact mkPt mkPt noEff where mkPt _ p _ = over particles' ((:) pt {_btTrail' = [p]}) aGenBulAt' :: Maybe Int -> Color -> Point2 -> Point2 -> HitEffect -> Float -> Particle' diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index 5e2e3b762..8b5125ddf 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -35,7 +35,6 @@ updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) d killBlock :: Wall -> World -> World killBlock bl w = f bl . flip (foldr unshadow) --- flip (foldr (\i -> set (walls . ix i . blVisible) (True))) (_blShadows bl) $ w where @@ -50,7 +49,8 @@ killBlock bl w = f bl . unshadow :: Int -> World -> World unshadow bid w = case w ^? walls . ix bid of Just b -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1) - in w & wallsZone . ix x . ix y . ix bid . blVisible %~ \_ -> True + in w & wallsZone . ix x . ix y . ix bid . blVisible %~ (\_ -> True) + & walls . ix bid . blVisible %~ \_ -> True Nothing -> w degradeBlock :: Wall -> World -> World diff --git a/src/Dodge/LevelGen/WindowBlock.hs b/src/Dodge/LevelGen/WindowBlock.hs index 456254760..82d5c5ec5 100644 --- a/src/Dodge/LevelGen/WindowBlock.hs +++ b/src/Dodge/LevelGen/WindowBlock.hs @@ -33,59 +33,6 @@ basePane = Block evenOddSplit = foldr f ([],[]) where f a (ls,rs) = (rs, a : ls) -putWindowBlock :: Point2 -> Point2 -> World -> World -putWindowBlock a b w = removePathsCrossing a b $ foldr (makeBlockAt bSide) w $ zip ps ns - where d = dist a b - rot = argV (b -.- a) - numPoints = 2 * floor (d / 20) - ns = take (numPoints+1) [0..] - ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) - $ map fromIntegral ns - bSide = d / (fromIntegral numPoints) - makeBlockAt :: Float -> (Point2,Int) -> World -> World - makeBlockAt bSide (p,i) w = - let k = newKey $ _walls w - ds = [(-bSide,-9),(-bSide,9),(bSide,9),(bSide,-9)] - polyAtP p = map ((+.+) p . rotateV rot) ds - ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3] - (k0:k1:k2:k3:_) = ksAtN i - (bl:tl:tr:br:_) = polyAtP p - shadows | i == 0 = ksAtN 1 - | i == numPoints - 1 = ksAtN $ numPoints - 2 - | otherwise = ksAtN (i-1) ++ ksAtN (i+1) - seen | even i = True - | otherwise = False - isLeftmost | i == 0 = True - | otherwise = False - isRightmost | i == numPoints = True - | otherwise = False - l = baseBlock - { _wlLine = [bl,tl] - , _wlID = k0 - , _blVisible = isLeftmost - } - t = baseBlock - { _wlLine = [tl,tr] - , _wlID = k1 - , _blVisible = seen - } - r = baseBlock - { _wlLine = [tr,br] - , _wlID = k2 - , _blVisible = isRightmost - } - b = baseBlock - { _wlLine = [br,bl] - , _wlID = k3 - , _blVisible = seen - } - baseBlock = basePane - { _blIDs = ksAtN i - , _blShadows = shadows - } - f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b - in over walls f w - putWindowBlock' :: Point2 -> Point2 -> World -> World putWindowBlock' a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks where d = dist a b @@ -108,11 +55,11 @@ putWindowBlock' a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks | i == numBlocks - 1 = [False,True, True,True] | otherwise = [False,True,False,True] shadowsAt i | i == 0 = ksAtI 1 - | i == numBlocks - 1 = ksAtI $ numBlocks - 1 + | i == numBlocks - 1 = ksAtI $ numBlocks - 2 | otherwise = ksAtI (i-1) ++ ksAtI (i+1) makeBlockAt :: Point2 -> Int -> [Wall] - makeBlockAt p i = zipWith3 (makePane i) (ksAtI i) (visibilityAt i) (linesAt p) - makePane i k' visStatus ps + makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) + makePane i visStatus k' ps = basePane {_wlID = k' ,_wlLine = ps ,_blIDs = ksAtI i diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index 22aa59d33..8e0b2cf6f 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -25,6 +25,7 @@ import Control.Monad.State import System.Random +import Data.Bifunctor import Data.Maybe import Data.Function import Data.List @@ -205,7 +206,7 @@ createSpark time colid pos dir maycid w = over worldEvents , _btPassThrough' = maycid , _btWidth' = 1 , _btTimer' = time - , _btHitEffect' = threeEff' sparkEff noEff noEff + , _btHitEffect' = destroyOnImpact sparkEff noEff noEff } x = fst $ randomR (0,20) $ _randGen w pos' = pos +.+ rotateV dir (x,0) @@ -228,7 +229,7 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents , _btPassThrough' = maycid , _btWidth' = 1 , _btTimer' = time - , _btHitEffect' = threeEff' sparkEff noEff noEff + , _btHitEffect' = destroyOnImpact sparkEff noEff noEff } x = fst $ randomR (0,20) $ _randGen w pos' = pos +.+ rotateV dir (x,0) @@ -243,22 +244,48 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents noEff _ _ _ = id -threeEff' :: - ( Particle' -> Point2 -> Creature -> World -> World ) -> - ( Particle' -> Point2 -> Wall -> World -> World ) -> - ( Particle' -> Point2 -> ForceField -> World -> World ) -> +type HitCreatureEffect = Particle' -> Point2 -> Creature -> World -> World +type HitWallEffect = Particle' -> Point2 -> Wall -> World -> World +type HitForceFieldEffect = Particle' -> Point2 -> ForceField -> World -> World + +destroyOnImpact :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect -> Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle') -threeEff' crEff wlEff ffEff pt hitThings w = case hitThings of - [] -> error "threeEff called without hitting anything" - ((p,E3x1 cr):_) -> (crEff pt p cr w, updatePt p) - ((p,E3x2 wl):_) -> (wlEff pt p wl w, updatePt p) - ((p,E3x3 ff):_) -> (ffEff pt p ff w, updatePt p) - where updatePt hitp = Just $ pt & btTrail' .~ (hitp : trl) - & ptPict' .~ bulLine col wth (hitp: trl) - & btTimer' .~ 3 +destroyOnImpact crEff wlEff ffEff pt hitThings w = case hitThings of + [] -> ( w, mvPt) + ((p,E3x1 cr):_) -> (crEff pt p cr w, destroyAt p) + ((p,E3x2 wl):_) -> (wlEff pt p wl w, destroyAt p) + ((p,E3x3 ff):_) -> (ffEff pt p ff w, destroyAt p) + where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl) + & ptPict' .~ bulLine col wth (hitp: trl) + & btTimer' .~ 3 + mvPt = Just $ pt & btTrail' .~ (newP : trl) + & ptPict' .~ bulLine col wth (newP : trl) + & btTimer' %~ (\t -> t - 1) + & btPassThrough' .~ Nothing trl = _btTrail' pt col = _btColor' pt wth = _btWidth' pt + newP = head trl +.+ _btVel' pt +penWalls :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect -> + Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle') +penWalls crEff wlEff ffEff pt hitThings w = case hitThings of + [] -> ( w, mvPt) + ((p,E3x1 cr):_) -> (crEff pt p cr w, destroyAt p) + ((p,E3x3 ff):_) -> (ffEff pt p ff w, destroyAt p) + ((p,E3x2 wl):hs) | isJust (wl ^? blHP) + -> first (wlEff pt p wl) $ penWalls crEff wlEff ffEff pt hs w + ((p,E3x2 wl):_) | otherwise -> (wlEff pt p wl w, destroyAt p) + where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl) + & ptPict' .~ bulLine col wth (hitp: trl) + & btTimer' .~ 3 + mvPt = Just $ pt & btTrail' .~ (newP : trl) + & ptPict' .~ bulLine col wth (newP : trl) + & btTimer' %~ (\t -> t - 1) + & btPassThrough' .~ Nothing + trl = _btTrail' pt + col = _btColor' pt + wth = _btWidth' pt + newP = head trl +.+ _btVel' pt makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World makeFlameletTimed pos vel levelInt maycid size time w @@ -273,7 +300,7 @@ makeFlameletTimed pos vel levelInt maycid size time w , _btPassThrough' = maycid , _btWidth' = size , _btTimer' = time - , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff } (rot ,g) = randomR (0,3) $ _randGen w @@ -288,7 +315,7 @@ makeFlamelet pos vel levelInt maycid size w = set randGen g $ over particles' (( , _btPassThrough' = maycid , _btWidth' = size , _btTimer' = 20 - , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff } (rot ,g) = randomR (0.5,1.5) $ _randGen w moveFlamelet :: Int -> Float -> World -> Particle' -> (World, Maybe Particle') diff --git a/src/Dodge/WorldEvent/Bullet.hs b/src/Dodge/WorldEvent/Bullet.hs index 21e595fc0..0668f52eb 100644 --- a/src/Dodge/WorldEvent/Bullet.hs +++ b/src/Dodge/WorldEvent/Bullet.hs @@ -88,13 +88,14 @@ mvGenBullet' w bt $ set ptPict' (bulLine col wth (p:p:ps)) $ set btTimer' (t-1) bt ) - | otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of - [] -> (w, Just $ set btPassThrough' Nothing - $ set btTrail' (p +.+ vel :p:ps) - $ set ptPict' (bulLine col wth (p +.+ vel:p:ps)) - $ set btTimer' (t-1) bt - ) - hits -> hiteff bt hits w + | otherwise = hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w +-- case thingsHitExceptCr mcr p (p +.+ vel) w of +-- [] -> (w, Just $ set btPassThrough' Nothing +-- $ set btTrail' (p +.+ vel :p:ps) +-- $ set ptPict' (bulLine col wth (p +.+ vel:p:ps)) +-- $ set btTimer' (t-1) bt +-- ) +-- hits -> hiteff bt hits w where mcr = _btPassThrough' bt col = _btColor' bt (p:ps) = _btTrail' bt diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 0d056fef0..a3a447d13 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -70,7 +70,9 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol renderFoldable pdata $ picToLTree (Just 2) pic + depthMask $= Disabled renderWalls pdata windowPoints pmat + depthMask $= Enabled resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata) endTicks <- SDL.ticks