From 79b2692199895d4128d27a3c2ae2729efe10a607 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 26 Sep 2021 12:09:44 +0100 Subject: [PATCH] Refactor inverse shockwave --- src/Dodge/Creature/Action.hs | 2 +- src/Dodge/Data.hs | 10 +-- src/Dodge/Item/Weapon/Decoration.hs | 2 +- src/Dodge/Item/Weapon/Grenade.hs | 2 +- src/Dodge/Item/Weapon/Laser.hs | 4 +- src/Dodge/Item/Weapon/UseEffect.hs | 12 +-- src/Dodge/Particle/Bullet/Spawn.hs | 8 +- src/Dodge/Render/Shape.hs | 4 +- src/Dodge/Update.hs | 2 +- src/Dodge/WorldEvent.hs | 2 +- src/Dodge/WorldEvent/Flash.hs | 6 +- src/Dodge/WorldEvent/HelperParticle.hs | 2 +- src/Dodge/WorldEvent/Shockwave.hs | 115 ++++++++++++------------- src/Dodge/WorldEvent/SpawnParticle.hs | 8 +- src/Loop.hs | 2 +- 15 files changed, 87 insertions(+), 94 deletions(-) diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 9c135422a..e1c650fd9 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -171,7 +171,7 @@ blinkAction cr w . over radDistortion (distortionBulge ++) . set (creatures . ix cid . crPos) p3 . blinkShockwave cid p3 - $ inverseShockwaveAt cpos 40 2 2 2 w + $ inverseShockwaveAt cpos 40 2 2 w where distR = 120 distortionBulge = diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index a2aada99a..1e71eee7d 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -402,18 +402,18 @@ Update themselves, perhaps with side effects. -} data Particle = Particle { _ptDraw :: Particle -> Picture - , _ptUpdate' :: World -> Particle -> (World, Maybe Particle) + , _ptUpdate :: World -> Particle -> (World, Maybe Particle) } | LinearParticle { _ptDraw :: Particle -> Picture - , _ptUpdate' :: World -> Particle -> (World, Maybe Particle) + , _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _ptPoints :: [Point2] , _ptTimer :: Int , _ptColor :: Color } | BulletPt { _ptDraw :: Particle -> Picture - , _ptUpdate' :: World -> Particle -> (World, Maybe Particle) + , _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _btVel' :: Point2 , _btColor' :: Color , _btTrail' :: [Point2] @@ -424,7 +424,7 @@ data Particle } | PtZ { _ptDraw :: Particle -> Picture - , _ptUpdate' :: World -> Particle -> (World, Maybe Particle) + , _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _btVel' :: Point2 , _btColor' :: Color , _btPos' :: Point2 @@ -436,7 +436,7 @@ data Particle } | Shockwave' { _ptDraw :: Particle -> Picture - , _ptUpdate' :: World -> Particle -> (World, Maybe Particle) + , _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _btColor' :: Color , _btPos' :: Point2 , _btRad' :: Float diff --git a/src/Dodge/Item/Weapon/Decoration.hs b/src/Dodge/Item/Weapon/Decoration.hs index e313b05e4..829c3d4db 100644 --- a/src/Dodge/Item/Weapon/Decoration.hs +++ b/src/Dodge/Item/Weapon/Decoration.hs @@ -21,7 +21,7 @@ makeLaserScope p ep relFrac = Particle ,lineAlphaThick 0.2 1.5 ,lineAlphaThick 0.1 2 ] - ,_ptUpdate' = \w pt -> (w, Just $ pt & ptUpdate' .~ \w' _ -> (w',Nothing)) + ,_ptUpdate = \w pt -> (w, Just $ pt & ptUpdate .~ \w' _ -> (w',Nothing)) } where lineAlphaThick a w = diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index bbcd0a446..006e7a399 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -21,7 +21,7 @@ moveGrenade :: Prop -> World -> World moveGrenade pj w | _pjTimer pj <= 0 = w & props %~ IM.delete pID - & (_pjPayload pj) (_pjPos (_props w IM.! pID)) + & _pjPayload pj (_pjPos (_props w IM.! pID)) | otherwise = case collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w of Nothing -> w & props . ix pID %~ normalUpdate Just (p,v) -> w diff --git a/src/Dodge/Item/Weapon/Laser.hs b/src/Dodge/Item/Weapon/Laser.hs index a97f958ca..9b1adf2b9 100644 --- a/src/Dodge/Item/Weapon/Laser.hs +++ b/src/Dodge/Item/Weapon/Laser.hs @@ -44,7 +44,7 @@ charToPhaseV _ = error "Trying to set an undefined phaseV" makeLaserAt :: Float -> Point2 -> Float -> Particle makeLaserAt phaseV pos dir = Particle { _ptDraw = const blank - , _ptUpdate' = moveLaser phaseV pos dir + , _ptUpdate = moveLaser phaseV pos dir } moveLaser @@ -56,7 +56,7 @@ moveLaser -> (World, Maybe Particle) moveLaser phaseV pos dir w pt = ( set randGen g $ hitEffect w - , Just pt {_ptDraw = const pic ,_ptUpdate' = ptTimer' 0 } + , Just pt {_ptDraw = const pic ,_ptUpdate = ptTimer' 0 } ) where xp = pos +.+ 800 *.* unitVectorAtAngle dir diff --git a/src/Dodge/Item/Weapon/UseEffect.hs b/src/Dodge/Item/Weapon/UseEffect.hs index 1bdb97a78..6b9909f4b 100644 --- a/src/Dodge/Item/Weapon/UseEffect.hs +++ b/src/Dodge/Item/Weapon/UseEffect.hs @@ -28,7 +28,7 @@ aRadarPulse cr = over particles (radarPulseAt (_crPos cr) :) blipAt :: Point2 -> Color -> Int -> Particle blipAt p col i = Particle {_ptDraw = const blank - ,_ptUpdate' = mvBlip p col i i + ,_ptUpdate = mvBlip p col i i } mvBlip :: Point2 -> Color -> Int -- ^ Max possible timer value @@ -37,7 +37,7 @@ mvBlip :: Point2 -> Color mvBlip _ _ _ 0 w _ = (w, Nothing) mvBlip p col maxt t w pt = (w - , Just $ pt & ptUpdate' .~ mvBlip p col maxt (t-1) + , Just $ pt & ptUpdate .~ mvBlip p col maxt (t-1) & ptDraw .~ ( const . setDepth (-0.5) . setLayer 1 @@ -47,7 +47,7 @@ mvBlip p col maxt t w pt = ) {- | An outwardly increasing circle that draws creatures, even those behind walls. -} sonarPulseAt :: Point2 -> Particle -sonarPulseAt p = Particle { _ptDraw = const blank , _ptUpdate' = mvSonar 100 p } +sonarPulseAt p = Particle { _ptDraw = const blank , _ptUpdate = mvSonar 100 p } mvSonar :: Int -- ^ Timer @@ -55,7 +55,7 @@ mvSonar -> World -> Particle -> (World, Maybe Particle) mvSonar 0 _ w _ = (w, Nothing) mvSonar x p w pt = (w, Just $ pt {_ptDraw = const pic - ,_ptUpdate' = mvSonar (x-1) p + ,_ptUpdate = mvSonar (x-1) p } ) where @@ -77,7 +77,7 @@ An outwardly increasing circle that displays walls, even those behind other wall radarPulseAt :: Point2 -> Particle radarPulseAt p = Particle { _ptDraw = const blank - , _ptUpdate' = mvRadar 50 p + , _ptUpdate = mvRadar 50 p } mvRadar :: Int -- ^ Timer @@ -86,7 +86,7 @@ mvRadar mvRadar 0 _ w _ = (w, Nothing) mvRadar x p w pt = ( putBlips w - , Just $ pt {_ptDraw = const pic ,_ptUpdate' = mvRadar (x-1) p } + , Just $ pt {_ptDraw = const pic ,_ptUpdate = mvRadar (x-1) p } ) where pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics diff --git a/src/Dodge/Particle/Bullet/Spawn.hs b/src/Dodge/Particle/Bullet/Spawn.hs index 071663a1f..8eaec7d20 100644 --- a/src/Dodge/Particle/Bullet/Spawn.hs +++ b/src/Dodge/Particle/Bullet/Spawn.hs @@ -18,7 +18,7 @@ aGenBulAt -> Particle aGenBulAt maycid pos vel hiteff width = BulletPt { _ptDraw = drawBul - , _ptUpdate' = mvGenBullet + , _ptUpdate = mvGenBullet , _btVel' = vel , _btColor' = V4 2 2 2 2 , _btTrail' = [pos] @@ -37,7 +37,7 @@ aDelayedBulAt -> Particle aDelayedBulAt vfact maycid pos vel hiteff width = BulletPt { _ptDraw = drawBul - , _ptUpdate' = \w -> resetVel . mvGenBullet w + , _ptUpdate = \w -> resetVel . mvGenBullet w , _btVel' = vfact *.* vel , _btColor' = V4 2 2 2 2 , _btTrail' = [pos] @@ -47,7 +47,7 @@ aDelayedBulAt vfact maycid pos vel hiteff width = BulletPt , _btHitEffect' = hiteff } where - resetVel = second $ fmap $ (ptUpdate' .~ mvGenBullet) . (btVel' .~ vel) + resetVel = second $ fmap $ (ptUpdate .~ mvGenBullet) . (btVel' .~ vel) aCurveBulAt :: Maybe Int -- ^ Pass-through creature id @@ -60,7 +60,7 @@ aCurveBulAt -> Particle aCurveBulAt maycid col pos control targ hiteff width = BulletPt { _ptDraw = drawBul - , _ptUpdate' = \w -> mvGenBullet w . setVel + , _ptUpdate = \w -> mvGenBullet w . setVel , _btVel' = V2 0 0 , _btColor' = col , _btTrail' = [pos] diff --git a/src/Dodge/Render/Shape.hs b/src/Dodge/Render/Shape.hs index 9ba2db6e6..11dd8cc43 100644 --- a/src/Dodge/Render/Shape.hs +++ b/src/Dodge/Render/Shape.hs @@ -12,8 +12,8 @@ import Dodge.Render.ShapePicture import qualified Data.IntMap as IM worldShape :: World -> Shape worldShape w = _foregroundShape w - <> foldMap (crShape w) (IM.elems $ IM.filter (pointIsClose . _crPos) (_creatures w)) - <> (foldMap (_spShape . floorItemSPic) $ IM.elems $ IM.filter (pointIsClose . _flItPos) $ _floorItems w) + <> foldMap (crShape w) (IM.filter (pointIsClose . _crPos) (_creatures w)) + <> foldMap (_spShape . floorItemSPic) (IM.filter (pointIsClose . _flItPos) $ _floorItems w) <> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w) where pointIsClose p = dist camCen p < winSize diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 9756eef51..f7f982d24 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -129,7 +129,7 @@ Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World updateParticles w = set particles (catMaybes ps) w' where - (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles w + (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w -- Note that this updates the randgen updateCreatures :: World -> World diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index ad72faa2f..aa25bfa9f 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -36,7 +36,7 @@ createBarrelSpark pos dir maycid time colid w where spark = BulletPt { _ptDraw = drawBul - , _ptUpdate' = mvGenBullet + , _ptUpdate = mvGenBullet , _btVel' = rotateV dir (V2 5 0) , _btColor' = numColor colid , _btTrail' = [pos] diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs index 00b82f78a..130328e34 100644 --- a/src/Dodge/WorldEvent/Flash.hs +++ b/src/Dodge/WorldEvent/Flash.hs @@ -60,7 +60,7 @@ glareBetween :: Int -> Float -> Float -> Color -> Point2 -> Point2 -> World -> M glareBetween 0 _ _ _ _ _ _ = Nothing glareBetween t len wdth col a b w = Just $ Particle {_ptDraw = const $ lowLightPic len wdth col (a,b) w - ,_ptUpdate' = \ w' _ -> (w',glareBetween (t-1) len wdth col a b w') + ,_ptUpdate = \ w' _ -> (w',glareBetween (t-1) len wdth col a b w') } lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture @@ -81,7 +81,7 @@ flashFlareAt :: Color -> Float -> Point2 -> Particle flashFlareAt col alphax (V2 x y) = Particle { _ptDraw = const $ setLayer 2 . setDepth (-0.9) . translate x y $ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30 - , _ptUpdate' = ptTimer' 1 + , _ptUpdate = ptTimer' 1 } explosionFlashAt :: Point2 -> World -> World @@ -109,7 +109,7 @@ muzzleFlashPt (V2 x y) = Particle . setLayer 2 . translate x y $ circleSolidCol (withAlpha 0 white) (withAlpha 0.2 white) 20 - , _ptUpdate' = ptTimer' 1 + , _ptUpdate = ptTimer' 1 } laserScopeTargetGlow :: Color -> Point2 -> World -> World diff --git a/src/Dodge/WorldEvent/HelperParticle.hs b/src/Dodge/WorldEvent/HelperParticle.hs index c0dda26b8..f10bcfe7b 100644 --- a/src/Dodge/WorldEvent/HelperParticle.hs +++ b/src/Dodge/WorldEvent/HelperParticle.hs @@ -6,4 +6,4 @@ import Dodge.Data {- A simple timer update for particles. -} ptTimer' :: Int -> World -> Particle -> (World, Maybe Particle) ptTimer' 0 w _ = (w, Nothing) -ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)}) +ptTimer' n w pt = (w, Just $ pt {_ptUpdate = ptTimer' (n-1)}) diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index 91f37dcb5..382bb4618 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -27,46 +27,36 @@ makeShockwaveAt -> World makeShockwaveAt is p rad dam push col = over particles (theShockwave :) where - theShockwave = shockwaveAt is p rad dam push col 10 - -shockwaveAt - :: [Int] -- ^ IDs of invulnerable creatures. - -> Point2 -> Float -> Int -> Float -> Color -> Int -> Particle -shockwaveAt is p rad dam push col maxtime - = Shockwave' + theShockwave = Shockwave' { _ptDraw = drawShockwave - , _ptUpdate' = mvShockwave is + , _ptUpdate = mvShockwave is , _btColor' = col , _btPos' = p , _btRad' = rad , _btDam' = dam , _btPush' = push - , _btMaxTime' = maxtime - , _btTimer' = maxtime + , _btMaxTime' = 10 + , _btTimer' = 10 } - -{- -Shockwave picture. --} +{- Shockwave picture. -} drawShockwave :: Particle -> Picture -drawShockwave pt = pic +drawShockwave pt = setDepth 20 + . setLayer 1 + . uncurryV translate (_btPos' pt) + . color (_btColor' pt) + $ thickCircle rad thickness where - pic = setDepth 20 . setLayer 1 . uncurryV translate p - $ color (_btColor' pt) $ thickCircle rad thickness - p = _btPos' pt r = _btRad' pt thickness = tFraction**2 * r rad = r - (3/4) * r * tFraction - tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) - t = _btTimer' pt + tFraction = fromIntegral (_btTimer' pt) / fromIntegral (_btMaxTime' pt) mvShockwave :: [Int] -- ^ IDs of invulnerable creatures. -> World -> Particle -> (World, Maybe Particle) mvShockwave is w pt - | _btTimer' pt <= 0 = (w, Nothing) - | otherwise - = (dams w , Just $ set btTimer' (t - 1) pt) -- $ set ptDraw (const pic) pt) + | _btTimer' pt <= 0 = ( w , Nothing) + | otherwise = (doDams w , Just $ pt & btTimer' -~ 1) where r = _btRad' pt p = _btPos' pt @@ -75,56 +65,59 @@ mvShockwave is w pt t = _btTimer' pt tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) rad = r - (3/4) * r * tFraction - dams = over creatures (IM.map damCr) . flip (IM.foldr (damageBlocksBy 1)) hitBlocks + doDams = over creatures (IM.map damCr) . flip (IM.foldl' (flip $ damageBlocksBy 1)) hitBlocks hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damCr cr | _crID cr `elem` is = cr - | dist (_crPos cr) p < rad + _crRad cr - = over (crState . crDamage) - ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p))) - cr - | otherwise = cr - -------------------------------------------------- - -{- -Create a shockwave going from an outside circle into a center point. - -} + damCr cr + | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr + | otherwise = cr & crState . crDamage %~ + (PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p)) : ) +{- Create a shockwave going from an outside circle into a center point. -} inverseShockwaveAt :: Point2 -- Center position -> Float -- Radius -> Int -- Damage -> Float -- Push amount - -> Float -- Push amount parameter -> World -> World -inverseShockwaveAt p rad _ push pushexp = over particles (theShockwave :) +inverseShockwaveAt p rad dam push = over particles (theShockwave :) where - theShockwave = Particle - { _ptDraw = const blank - , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp + theShockwave = Shockwave' + { _ptDraw = drawInverseShockwave + , _ptUpdate = moveInverseShockwave + , _btColor' = cyan + , _btPos' = p + , _btRad' = rad + , _btDam' = dam + , _btPush' = push + , _btMaxTime' = 10 + , _btTimer' = 10 } -moveInverseShockWave - :: Int -- ^ Timer - -> Point2 -- ^ Center position - -> Float -- ^ Radius - -> Float -- ^ Push amount - -> Float -- ^ Push amount parameter - -> World +moveInverseShockwave + :: World -> Particle -> (World, Maybe Particle) -moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing) -moveInverseShockWave t p r push pushexp w pt - = (dams w, Just $ newupdate $ newpic pt ) +moveInverseShockwave w pt + | t <= 0 = ( w, Nothing) + | otherwise = (dams w, Just $ btTimer' -~ 1 $ pt ) where - newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp - newpic = set ptDraw (const $ onLayer PtLayer $ uncurryV translate p - $ color cyan $ thickCircle rad thickness) - rad = r - (4/40) * r * fromIntegral (10 - t) - thickness = fromIntegral (10 - t) **2 * rad / 40 + p = _btPos' pt + r = _btRad' pt + t = _btTimer' pt + rad = r - 0.1 * r * fromIntegral (10 - t) dams = over creatures (IM.map damCr) . flip (foldr (damageBlocksBy 1)) hitBlocks hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damCr cr | dist (_crPos cr) p < rad + _crRad cr - = over (crState . crDamage) - ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr))) - cr - | otherwise = cr + damCr cr + | dist (_crPos cr) p >= rad + _crRad cr = cr + | otherwise = cr & crState . crDamage %~ + (PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)) :) + +drawInverseShockwave :: Particle -> Picture +drawInverseShockwave pt + = setLayer 1 $ onLayer PtLayer $ uncurryV translate p + $ color cyan $ thickCircle rad thickness + where + p = _btPos' pt + r = _btRad' pt + t = _btTimer' pt + rad = r - 0.1 * r * fromIntegral (10 - t) + thickness = fromIntegral (10 - t) **2 * rad / 40 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 752f74bb4..26c4910f2 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -44,7 +44,7 @@ aFlameParticle -> Particle aFlameParticle t pos vel maycid = PtZ { _ptDraw = drawFlame vel - , _ptUpdate' = moveFlame vel + , _ptUpdate = moveFlame vel , _btVel' = vel , _btColor' = red , _btPos' = pos @@ -152,7 +152,7 @@ makeFlameletTimed (V2 x y) z vel maycid size time w = w where theFlamelet = PtZ { _ptDraw = drawFlameletZ rot - , _ptUpdate' = moveFlamelet + , _ptUpdate = moveFlamelet , _btVel' = vel , _btColor' = red , _btPos' = V2 x y @@ -307,7 +307,7 @@ makeTeslaArcAt :: Color -> Point2 -> Float -> Particle makeTeslaArcAt col pos dir = LinearParticle { _ptPoints = [pos] , _ptDraw = drawTeslaArc - , _ptUpdate' = moveTeslaArc pos dir + , _ptUpdate = moveTeslaArc pos dir , _ptTimer = 2 , _ptColor = brightX 100 1.5 col } @@ -460,7 +460,7 @@ createSparkCol time col pos dir w where spark = BulletPt { _ptDraw = drawBul - , _ptUpdate' = mvGenBullet + , _ptUpdate = mvGenBullet , _btVel' = rotateV dir (V2 5 0) , _btColor' = col , _btTrail' = [pos] diff --git a/src/Loop.hs b/src/Loop.hs index 66446ee4d..b4cef294a 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} {- | Module : Loop Description : Simple game loop