Move wall damages to external position

src/Dodge/Base/Collide.hs

@@ -22,6 +22,7 @@ module Dodge.Base.Collide
     , collidePointWalls
     , collidePointWallsNorm
     , collidePointWalls'
+    , collidePointWallsFilt'
     , overlapCircWallsReturnWall
     , collideCircCrsPoint
     , collideCircCreatures
@@ -373,6 +374,9 @@ collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
   where
     findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
 
+collidePointWallsFilt' :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
+collidePointWallsFilt' t p1 p2 = collidePointWalls p1 p2 . IM.filter t
+
 -- | Looks for first collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
 -- note that the "intersection" point is the center of the circle flush against the wall

src/Dodge/Data.hs

@@ -106,6 +106,7 @@ data World = World
     , _newBeams             :: WorldBeams
     , _beams                :: WorldBeams
     , _walls                :: IM.IntMap Wall
+    , _wallDamages          :: IM.IntMap [Damage]
     , _doors                :: IM.IntMap Door
     , _machines             :: IM.IntMap Machine
     , _terminals            :: IM.IntMap Terminal
@@ -1029,7 +1030,7 @@ data Wall = Wall
     , _wlRotateTo       :: Bool
     , _wlStructure      :: WallStructure
     , _wlHeight         :: Float
-    , _wlDamageEff      :: Damage -> Wall -> World -> World
+--    , _wlDamageEff      :: Damage -> Wall -> World -> World
     , _wlMaterial       :: Material
     }
 data Opacity
@@ -1044,7 +1045,7 @@ data WallStructure
     | BlockPart   { _wsBlock   :: Int }
     | CreaturePart 
         { _wlStCreature :: Int 
-        , _wlStDamCreature :: Damage -> Wall -> Int -> World -> World
+--        , _wlStDamCreature :: Damage -> Wall -> Int -> World -> World
         }
 
 data ActionPlan

src/Dodge/Data/Wall.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Dodge.Data.Wall where

src/Dodge/Default/Wall.hs

@@ -22,7 +22,6 @@ defaultWall = Wall
     , _wlStructure = StandaloneWall
     , _wlWalkable = False
     , _wlHeight = 100
-    , _wlDamageEff = defaultWallDamage
     , _wlMaterial = Stone
     }
 {- Indestructible see-through wall.  -}
@@ -55,7 +54,6 @@ defaultDirtWall = defaultWall
 defaultWindow :: Wall
 defaultWindow = defaultWall
     { _wlLine = (V2 0 0,V2 50 0)
-    , _wlDamageEff = windowWallDamage
     , _wlID = 0
     , _wlColor = withAlpha 0.5 cyan
     , _wlSeen = False

src/Dodge/Default/World.hs

@@ -44,6 +44,7 @@ defaultWorld = World
     , _newBeams = WorldBeams [] [] [] []
     , _beams = WorldBeams [] [] [] []
     , _walls = IM.empty
+    , _wallDamages = IM.empty
     , _blocks = IM.empty
     , _machines = IM.empty
     , _terminals = IM.empty

src/Dodge/Item/Equipment.hs

@@ -157,7 +157,7 @@ shieldWall crid = defaultWall
     ,_wlReflect = True
     ,_wlDraw = False
     ,_wlRotateTo = False
-    ,_wlStructure = CreaturePart crid shieldWallDamage
+    ,_wlStructure = CreaturePart crid -- shieldWallDamage
     }
 
 -- TODO the reflection should be controled by the particle

src/Dodge/Particle/HitEffect/ExpireAndDamage.hs

@@ -1,9 +1,10 @@
 module Dodge.Particle.HitEffect.ExpireAndDamage where
 import Dodge.Data
 import Dodge.Particle.Update
-import Dodge.Wall.Damage
+--import Dodge.Wall.Damage
 import Geometry
 import LensHelp
+import qualified Data.IntMap.Strict as IM
 
 expireAndDamage :: (Particle -> Point2 -> [Damage])
     -> Particle
@@ -21,7 +22,6 @@ doDamages :: (Particle -> Point2 -> [Damage])
     -> World
 doDamages fdm (p,thhit) bt = case thhit of
     Left cr -> creatures . ix (_crID cr) . crState . crDamage .++~ dams
-    Right wl -> flip (foldr (`damageWall` wl)) dams
+    Right wl -> wallDamages %~ IM.insertWith (++) (_wlID wl) dams
   where
     dams = fdm bt p
-

src/Dodge/PlacementSpot.hs

@@ -85,13 +85,13 @@ rpIsOffPath = any f . _rpType
 rpOffPathEdge :: PathEdge -> RoomPos -> Bool
 rpOffPathEdge pe = any f . _rpType
   where
-    f rt = maybe False (any (== pe)) (rt ^? offPathEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? offPathEdges) 
 
 -- test whether a roomPos is on the path with a given from edge value
 rpOnPathEdge :: PathEdge -> RoomPos -> Bool
 rpOnPathEdge pe = any f . _rpType
   where
-    f rt = maybe False (any (== pe)) (rt ^? onPathEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? onPathEdges) 
 
 resetPLUse :: PlacementSpot -> PlacementSpot
 resetPLUse (PSPos f g fallback) = PSPos f' g fallback

src/Dodge/Room/Procedural.hs

@@ -71,7 +71,7 @@ roomRect x y xn yn = defaultRoom
         , _rmHeight = y
         }
     }
-  where 
+  where
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
     somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)

src/Dodge/Room/Room.hs

@@ -208,9 +208,9 @@ weaponBetweenPillars = do
         rpIsOnPath rp
         && _rpPlacementUse rp == 0
         && all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
-    (fmap pure $ roomPillars 30 w h wn hn 
+    (roomPillars 30 w h wn hn 
         <&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [ sps wpPos (PutFlIt wp) ]
-        <&> cleatOnward) >>= rToOnward ("weaponBetweenPillars_"++itemString wp)
+        <&> cleatOnward) >>= rToOnward ("weaponBetweenPillars_"++itemString wp) . pure
 
 weaponLongCorridor :: RandomGen g => State g (Tree Room)
 weaponLongCorridor = do

src/Dodge/Update.hs

@@ -10,6 +10,7 @@ import Dodge.Block
 import Dodge.Distortion
 import Dodge.SoundLogic
 import Dodge.Wall.Delete
+import Dodge.Update.WallDamage
 --import Dodge.Menu
 import Dodge.Base
 import Dodge.Zone
@@ -82,6 +83,7 @@ functionalUpdate cfig w = checkEndGame
     . over creatures (fmap setOldPos)
     . updateCreatureGroups
     . updateBlocks
+    . updateWallDamages
     . updateSeenWalls 
 --    . (youHammerPosition %~ moveHammerUp)
     . updateTerminal
@@ -95,6 +97,7 @@ functionalUpdate cfig w = checkEndGame
       where 
         (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
 
+
 updateBoundBox :: Configuration -> World -> World
 updateBoundBox cfig w = w & boundBox .~ cullBox cfig w
 

src/Dodge/Update/Camera.hs

@@ -210,7 +210,7 @@ farWallDistDirection :: Point2 -> Configuration -> World -> (Float,Float,Float,F
 --farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
 farWallDistDirection p cfig w = foldr (m . f) (0,0,0,0) vps
   where
-    f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWalls' p q (IM.filter wlIsOpaque wos) -.- p
+    f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilt' wlIsOpaque p q wos -.- p
     g (V2 x y) = (y, negate y, x, negate x)
     m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w')
     vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs

src/Dodge/Update/WallDamage.hs

@@ -0,0 +1,16 @@
+module Dodge.Update.WallDamage where
+import Dodge.Wall.Damage
+import Dodge.Data
+
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
+import Data.Maybe
+
+updateWallDamages :: World -> World
+updateWallDamages w = w
+    & wallDamages .~ IM.empty
+    & flip (IM.foldrWithKey f) (_wallDamages w)
+  where
+    f k dams w' = fromMaybe w' $ do
+        wl <- w' ^? walls . ix k
+        return $ foldr (flip damageWall wl) w' dams

src/Dodge/Wall/Damage.hs

@@ -7,13 +7,14 @@ module Dodge.Wall.Damage
     ) where
 import Dodge.Data
 import LensHelp
+import Dodge.Wall.DamageEffect
 
 damageWall :: Damage -> Wall -> World -> World
 damageWall dt wl = case _wlStructure wl of
-    MachinePart mcid -> _wlDamageEff wl dt wl . (machines . ix mcid . mcDamage .:~ dt)
-    BlockPart blid   -> _wlDamageEff wl dt wl . (blocks . ix blid %~ damageBlockWith dt)
-    CreaturePart crid f -> f dt wl crid
-    _   -> _wlDamageEff wl dt wl
+    MachinePart mcid -> defaultWallDamage dt wl . (machines . ix mcid . mcDamage .:~ dt)
+    BlockPart blid   -> defaultWallDamage dt wl . (blocks . ix blid %~ damageBlockWith dt)
+--    CreaturePart crid f -> f dt wl crid
+    _   -> defaultWallDamage dt wl
 
 damageBlockWith :: Damage -> Block -> Block
 damageBlockWith dm = case _dmType dm of