Move wall destruction

src/Dodge/Wall/Damage.hs

@@ -1,8 +1,20 @@
+{-# LANGUAGE LambdaCase #-}
 {- | Controls a walls response to external damage.
  - Indestructible walls may still produce sparks, dust etc
 -}
 module Dodge.Wall.Damage (damageWall) where
 
+import Linear
+import Data.Maybe
+import Dodge.LightSource
+import Data.Foldable
+import Dodge.ShiftPoint
+import Dodge.Zoning.Pathing
+import Dodge.Zoning.Base
+import Dodge.Door.DoorLerp
+import Dodge.Wall.Delete
+import Dodge.Block.Debris
+import qualified Data.IntMap.Strict as IM
 import Geometry.Data
 import Dodge.Material.Damage
 import Dodge.Block
@@ -18,8 +30,8 @@ damageWall dt wl (is,w) = case _wlStructure wl of
         w' & cWorld . lWorld . blocks . ix blid . blHP -~ dmam
             & maybeDestroyBlock is blid
     DoorPart drid _ ->
-        f $ w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam
---            & maybeDestroyDoor drid
+        w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam
+            & maybeDestroyDoor is drid
     _ -> f w'
   where
     f = (,) is
@@ -34,7 +46,41 @@ maybeDestroyBlock is blid w = case w ^? cWorld . lWorld . blocks . ix blid of
     Just bl | _blHP bl < 1 -> destroyBlock is bl w
     _ -> (is,w)
 
---maybeDestroyDoor :: Int -> World -> World
---maybeDestroyDoor drid w = case w ^? cWorld . lWorld . doors . ix drid of
---    Just dr | _drHP dr < 1 -> destroyDoor dr w
---    _ -> w
+maybeDestroyDoor :: S.Set Int2 -> Int -> World -> (S.Set Int2, World)
+maybeDestroyDoor is drid w = case w ^? cWorld . lWorld . doors . ix drid of
+    Just dr | _drHP dr < 1 -> destroyDoor dr w
+    _ -> (is,w)
+
+destroyDoor :: Door -> World -> (S.Set Int2, World)
+destroyDoor dr w =
+    ( is
+    , w
+        & makeDoorDebris dr
+        & deleteWallIDs wlids
+        & cWorld . lWorld . doors . at (dr ^. drID) .~ Nothing -- %~ IM.delete (_drID dr)
+        --        & muchWlDustAt awl (0.5 * uncurry (+) (_drPos dr))
+        --        & flip (foldl' (flip $ muchWlDustAt awl)) (map (pos +.+) ps)
+        & stopPushing (dr ^. drPushes)
+        & destroyMounts pa (dr ^. drMounts)
+    )
+  where
+    pa = doDoorLerp dr (dr ^. drLerp)
+    is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
+    ps = (dr ^. drFootPrint) & each . each %~ shiftPointBy pa
+    wlids = IM.keysSet $ _drFootPrint dr
+
+destroyMounts :: Point2A -> [MountedObject] -> World -> World
+destroyMounts pa mos w = foldl' (flip $ destroyMount pa) w mos
+
+destroyMount :: Point2A -> MountedObject -> World -> World
+destroyMount pa = \case
+    MountedLight x _ _ -> destroyLSFlashAt $ x & _xy %~ shiftPointBy pa
+    MountedSPic{} -> id -- make debris?
+
+stopPushing :: Maybe Int -> World -> World
+stopPushing mdrid w = fromMaybe w $ do
+    drid <- mdrid
+    dr <- w ^? cWorld . lWorld . doors . ix drid
+    return $
+        w & cWorld . lWorld . doors . ix drid . drUpdate .~ DoorDoNothing
+            & stopPushing (_drPushes dr)

src/Dodge/Wall/Draw.hs

@@ -1,20 +1,23 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Dodge.Wall.Draw (drawWall) where
 
-import Dodge.Material.Color
+import Control.Lens
 import Dodge.Data.Wall
+import Dodge.Material.Color
 import Picture.Base
 import ShapePicture
-import Control.Lens
 
 drawWall :: WallDraw -> Wall -> SPic
-drawWall wd = case wd of
+drawWall = \case
     DrawForceField -> drawForceField
 
 drawForceField :: Wall -> SPic
-drawForceField wl = noShape . setLayer BloomLayer
+drawForceField wl =
+    noShape 
+        . setLayer BloomLayer
         . setDepth 20
         . color (materialColor (wl ^. wlMaterial))
---        . color (_wlColor wl)
         $ thickLine 5 [a, b]
   where
     (a, b) = _wlLine wl