Modularise shockwaves, stop landing self damage when blinking

app/Main.hs

@@ -26,7 +26,7 @@ import Control.Concurrent
 import Control.Lens
 import Foreign (Word32)
 
-import Control.Monad (when)
+import Control.Monad (when,void)
  
 import System.Random
 
@@ -53,7 +53,7 @@ main = do
         (fmap (setWindowSize sizex sizey keyConfig) firstWorld)
         ( \preData w -> do
             startTicks <- SDL.ticks
-            doDrawing (_renderData preData) w
+            void $ doDrawing (_renderData preData) w
             playSoundQueue (_soundData preData) (_soundQueue w)
             newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
 

src/Dodge/CreatureAction.hs

@@ -7,7 +7,7 @@ module Dodge.CreatureAction
     where
 -- imports {{{
 import Dodge.CreatureAction.UseItem
-
+import Dodge.WorldEvent.Shockwave
 import Dodge.Data
 import Dodge.Base
 import Dodge.SoundLogic
@@ -222,7 +222,7 @@ createItemAt p it w = over floorItems (IM.insert i (set flItPos p
 
 blinkAction :: Int -> World -> World
 blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
-                    $ blinkShockwave p3
+                    $ blinkShockwave n p3
                     $ inverseShockwaveAt cp 40 2 2 2 
                         w
     where   p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
@@ -231,8 +231,12 @@ blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
             r  = 1.5 * _crRad (_creatures w IM.! n)
             p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
 
-blinkShockwave :: Point2 -> World -> World
+blinkShockwave 
-blinkShockwave p = makeShockwaveAt p 40 1 2 cyan 
+    :: Int      -- ^ Blinking creature ID.
+    -> Point2 
+    -> World 
+    -> World
+blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan 
 
 moveAmountToward :: Point2 -> Float -> Point2 -> Point2
 moveAmountToward p1 am p2

src/Dodge/Item/Weapon.hs

@@ -920,9 +920,6 @@ flamerAngle = 0.3
 aSelf :: Int -> World -> World
 aSelf = blinkAction
 
-
-
-
 reflect :: Float -> Float -> Float
 reflect a b = a + 2*(a-b)
 

src/Dodge/Item/Weapon/Bullet.hs

@@ -5,6 +5,7 @@ import Dodge.Base
 import Dodge.WorldEvent
 import Dodge.SoundLogic
 import Dodge.RandomHelp
+import Dodge.WorldEvent.Shockwave
 
 import Dodge.Creature.Property
 
@@ -129,7 +130,7 @@ bulConCr' bt p cr w
     where   cid = _crID cr
             sp = head $ _btTrail' bt
             ep = sp +.+ _btVel' bt
-            mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
+            mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
 
 bulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
 bulHitWall' bt p x w =  damageBlocks x
@@ -195,7 +196,7 @@ bulConWall' bt p wl w =  damageBlocks wl
                   Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
                   _ -> w
             wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
-            mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
+            mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
 
 hvBulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
 hvBulHitWall' bt p x w =  damageBlocks x

src/Dodge/WorldEvent.hs

@@ -19,6 +19,7 @@ import Dodge.WorldEvent.Cloud
 import Dodge.WorldEvent.HitEffect
 import Dodge.WorldEvent.Explosion
 import Dodge.WorldEvent.SpawnParticle
+import Dodge.WorldEvent.Shockwave
 import Dodge.LightSources
 
 import Dodge.Data
@@ -38,52 +39,6 @@ import Data.Function
 import Data.List
 import qualified Data.IntMap.Strict as IM
 
-
-shockWaveDamage :: Point2 -> Float -> Int -> World -> World
-shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w
-    where f cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage) 
-                                                             ((:) $ Concussive amount p 2 0.5 rad) cr
-               | otherwise                            = cr
-          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
-          damageBlocks wall w
-            = case wall ^? blHP of 
-                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - (div amount 2))) 
-                                 w 
-                                 (_blIDs wall)
-                _ -> w
-
-
-inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
-inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
-    where theShockwave 
-            = Particle' 
-                { _ptDraw = const blank
-                , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
-                }
-moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
-moveInverseShockWave 0 _ _ _    _       w _  = (w, Nothing)
-moveInverseShockWave t p r push pushexp w pt 
-    = (dams w, Just $ newupdate $ newpic pt )
-    where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
-          newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p 
-                                $ color cyan $ thickCircle rad thickness)
-          rad = r - (4/40) * r * fromIntegral (10 - t)
-          thickness = (fromIntegral (10 - t))**2 * rad / 40
-          dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
-          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
-          damageBlocks wall w
-            = case wall ^? blHP of 
-                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
-                                 w 
-                                 (_blIDs wall)
-                _ -> w
-          damCr cr | dist (_crPos cr) p < rad + _crRad cr 
-                                = over (crState . crDamage) 
-                                       ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
-                                       cr
-                   | otherwise  = cr
-    
-
 createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
 createBarrelSpark time colid pos dir maycid w = over worldEvents 
                                         ((.) $ ( over particles' ((:) spark) 

src/Dodge/WorldEvent/Explosion.hs

@@ -7,7 +7,7 @@ import Dodge.WorldEvent.SpawnParticle
 import Dodge.WorldEvent.Flash
 import Dodge.RandomHelp
 import Dodge.SoundLogic
-
+import Dodge.WorldEvent.Shockwave
 import Geometry
 import Picture
 
@@ -57,7 +57,7 @@ makeExplosionAt :: Point2 -> World -> World
 makeExplosionAt p w = soundOnce grenadeBang 
     . addFlames 
     . explosionFlashAt p
-    $ makeShockwaveAt p 50 10 1 white
+    $ makeShockwaveAt [] p 50 10 1 white
         w
   where 
     fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w
@@ -74,73 +74,3 @@ makeExplosionAt p w = soundOnce grenadeBang
     pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y) 
                                      $ collidePointWalls p q $ wallsNearPoint q w
 
-makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color
-                 -> World -> World
-makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave)
-    where theShockwave = shockwaveAt p rad dam push col 10
-
-shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
-shockwaveAt p rad dam push col maxtime
-    = Shockwave'
-        { _ptDraw       = const blank
-        , _ptUpdate'    = mvShockwave'
-        , _btColor'     = col
-        , _btPos'       = p
-        , _btRad'       = rad
-        , _btDam'       = dam
-        , _btPush'      = push
-        , _btMaxTime'   = maxtime
-        , _btTimer'     = maxtime
-        }
-
-mvShockwave' :: World -> Particle' -> (World, Maybe Particle')
-mvShockwave' w pt 
-    | _btTimer' pt <= 0 = (w, Nothing)
-    | otherwise
-        = (dams w , Just $ set btTimer' (t - 1) $ set ptDraw (const pic) pt)
-  where 
-    r    = _btRad' pt
-    p    = _btPos' pt
-    push = _btPush' pt
-    dam  = _btDam' pt
-    t    = _btTimer' pt
-    tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
-    pic = onLayer PtLayer $ uncurry translate p 
-                          $ color (_btColor' pt) $ thickCircle rad thickness
-    rad = r - (3/4) * r * tFraction
-    thickness = tFraction**2 * r 
-    dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
-    hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
-    damageBlocks wall w
-      = case wall ^? blHP of 
-          Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
-                           w 
-                           (_blIDs wall)
-          _ -> w
-    damCr cr | dist (_crPos cr) p < rad + _crRad cr 
-                          = over (crState . crDamage) 
-                                 ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p)))
-                                 cr
-             | otherwise  = cr
-moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
-moveShockWave 0 _ _ _    _       w _  = (w, Nothing)
-moveShockWave t p r push pushexp w pt 
-    = (dams w, Just $ newupdate $ newpic pt )
-    where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp
-          newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p 
-                                $ color cyan $ thickCircle rad thickness)
-          rad = r - (3/40) * r * fromIntegral t
-          thickness = (fromIntegral t)**2 * rad / 40
-          dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
-          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
-          damageBlocks wall w
-            = case wall ^? blHP of 
-                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
-                                 w 
-                                 (_blIDs wall)
-                _ -> w
-          damCr cr | dist (_crPos cr) p < rad + _crRad cr 
-                                = over (crState . crDamage) 
-                                       ((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p)))
-                                       cr
-                   | otherwise  = cr

src/Dodge/WorldEvent/Shockwave.hs

@@ -0,0 +1,114 @@
+module Dodge.WorldEvent.Shockwave
+    ( makeShockwaveAt
+    , inverseShockwaveAt
+    )
+  where
+import Dodge.Data
+import Dodge.Base
+import Geometry
+import Picture
+
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
+
+makeShockwaveAt 
+    :: [Int]    -- ^ IDs of invulnerable creatures.
+    -> Point2   -- ^ Center of shockwave.
+    -> Float    -- ^ Maximal radius.
+    -> Int      -- ^ Damage caused per frame.
+    -> Float    -- ^ Amount of pushback per frame.
+    -> Color    -- ^ Color of shockwave.
+    -> World    -- ^ Start world.
+    -> 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'
+        { _ptDraw       = drawShockwave
+        , _ptUpdate'    = mvShockwave' is
+        , _btColor'     = col
+        , _btPos'       = p
+        , _btRad'       = rad
+        , _btDam'       = dam
+        , _btPush'      = push
+        , _btMaxTime'   = maxtime
+        , _btTimer'     = maxtime
+        }
+
+drawShockwave :: Particle' -> Picture
+drawShockwave pt = pic 
+  where
+    pic = onLayer PtLayer $ uncurry 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
+
+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)
+  where 
+    r    = _btRad' pt
+    p    = _btPos' pt
+    push = _btPush' pt
+    dam  = _btDam' pt
+    t    = _btTimer' pt
+    tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
+    rad = r - (3/4) * r * tFraction
+    dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
+    hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+    damageBlocks wall w
+      = case wall ^? blHP of 
+          Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
+                           w 
+                           (_blIDs wall)
+          _ -> 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
+
+-------------------------------------------------
+
+inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
+inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
+    where theShockwave 
+            = Particle' 
+                { _ptDraw = const blank
+                , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
+                }
+moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
+moveInverseShockWave 0 _ _ _    _       w _  = (w, Nothing)
+moveInverseShockWave t p r push pushexp w pt 
+    = (dams w, Just $ newupdate $ newpic pt )
+    where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
+          newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p 
+                                $ color cyan $ thickCircle rad thickness)
+          rad = r - (4/40) * r * fromIntegral (10 - t)
+          thickness = (fromIntegral (10 - t))**2 * rad / 40
+          dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
+          hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+          damageBlocks wall w
+            = case wall ^? blHP of 
+                Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) 
+                                 w 
+                                 (_blIDs wall)
+                _ -> w
+          damCr cr | dist (_crPos cr) p < rad + _crRad cr 
+                                = over (crState . crDamage) 
+                                       ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
+                                       cr
+                   | otherwise  = cr

src/Geometry/Intersect.hs

@@ -115,17 +115,20 @@ ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoin
           toNumPoint2 (x,y) = (fromRational x, fromRational y)
           f = toRatPoint2 . roundPoint2
 
--- | Round the floats within a 'Point2' to the nearest integer.
+{- | Round the floats within a 'Point2' to the nearest integer.
--- Rounding jumps after intervals of .5:
+__Examples__
---
+Rounding jumps after intervals of .5:
--- >>> roundPoint (0.5,0.5001)
+
--- (0.0,1.0)
+>>> roundPoint (0.5,0.5001)
---
+(0.0,1.0)
--- but is symmetric around 0:
+
---
+but is symmetric around 0:
--- >>> roundPoint2 (0.5,-0.5)
+
--- (0.0,0.0)
+>>> roundPoint2 (0.5,-0.5)
---
+(0.0,0.0)
+
+-}
+
 roundPoint2 :: Point2 -> Point2
 roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)