Move wall destruction

src/Dodge/Debug/Picture.hs

@@ -323,10 +323,9 @@ drawDDATest w =
     g [_,b,_,d] = color blue $ thickLine 2 [b,d]
     g _ = undefined
     ps = zoneOfSeg 50 x y
-    qs = map (zoneOfPoint 50) $ xIntercepts' 50 x y
+    qs = map (zoneOfPoint 50) $ xIntercepts 50 x y
-    rs = map (zoneOfPoint 50) $ yIntercepts' 50 x y
+    rs = map (zoneOfPoint 50) $ yIntercepts 50 x y
-    xs = xIntercepts' 50 x y
+    xs = xIntercepts 50 x y
---    xs' = xIntercepts' 50 x y
 
 drawWallSearchRays :: World -> Picture
 drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w

src/Dodge/Door.hs

@@ -3,16 +3,12 @@
 module Dodge.Door (updateDoor) where
 
 import Data.Foldable
-import qualified Data.IntMap.Strict as IM
 import Data.Maybe
 import qualified Data.Set as S
-import Dodge.Block.Debris
 import Dodge.Data.World
 import Dodge.Door.DoorLerp
-import Dodge.LightSource
 import Dodge.ShiftPoint
 import Dodge.SoundLogic
-import Dodge.Wall.Delete
 import Dodge.Wall.Move
 import Dodge.WorldBool
 import Dodge.Zoning.Base
@@ -25,7 +21,6 @@ import Shape.Data
 
 updateDoor :: Door -> World -> (S.Set Int2, World)
 updateDoor dr w
-    | dr ^. drHP < 1 = destroyDoor dr w
     | DoorLerp x <- dr ^. drUpdate = doorLerp x dr w
     | otherwise =
         ( mempty
@@ -73,36 +68,3 @@ doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do
             soundContinue (WallSound drid) (fst $ doDoorLerp dr x) slideDoorS (Just 1)
         | otherwise = id
 
-destroyDoor :: Door -> World -> (S.Set Int2, World)
-destroyDoor dr w =
-    ( is
-    , w
-        & makeDoorDebris dr
-        & deleteWallIDs wlids
-        & cWorld . lWorld . doors %~ 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/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
+        w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam
---            & maybeDestroyDoor drid
+            & 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 :: S.Set Int2 -> Int -> World -> (S.Set Int2, World)
---maybeDestroyDoor drid w = case w ^? cWorld . lWorld . doors . ix drid of
+maybeDestroyDoor is drid w = case w ^? cWorld . lWorld . doors . ix drid of
---    Just dr | _drHP dr < 1 -> destroyDoor dr w
+    Just dr | _drHP dr < 1 -> destroyDoor dr w
---    _ -> 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

src/Dodge/Zoning/Base.hs

@@ -11,8 +11,6 @@ module Dodge.Zoning.Base
     , zoneOfCirc
     , zonesAroundPoint
     , xIntercepts
-    , xIntercepts'
-    , yIntercepts'
     , yIntercepts
     , updateInt2Map
     ) where
@@ -50,8 +48,7 @@ zoneOfPoint = fmap . divTo
 
 zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2]
 {-# INLINE zoneOfSeg #-}
---zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
+zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
-zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep)
 
 zoneOfSegSet :: Float -> Point2 -> Point2 -> S.Set Int2
 {-# INLINE zoneOfSegSet #-}
@@ -68,23 +65,7 @@ zonesExtract = foldMap . flip zoneExtract
 
 xIntercepts :: Float -> Point2 -> Point2 -> [Point2]
 {-# INLINE xIntercepts #-}
-xIntercepts s (V2 sx sy) (V2 ex ey)
+xIntercepts s (V2 sx sy) (V2 ex ey) 
-    | divTo s sx == divTo s ex = []
-    | otherwise = zipWith V2 [halfstep + sx', halfstep + sx' + xdx * s .. ex] ([sy', sy' + ydx * s .. ey] ++ repeat ey)
-  where
-    halfstep
-        | xdx > 0 = -s/2
-        | otherwise = s/2
-    xdx = signum (ex - sx)
-    ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero
-    sy' = sy + ydx * abs (sx - sx')
-    sx'
-        | xdx < 0 = sx - modTo s sx
-        | otherwise = s + sx - modTo s sx
-
-xIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
-{-# INLINE xIntercepts' #-}
-xIntercepts' s (V2 sx sy) (V2 ex ey) 
     | divTo s sx == divTo s ex = []
     | otherwise = g <$> [a, a + s .. b]
   where
@@ -100,12 +81,6 @@ yIntercepts s sp ep = map f $ xIntercepts s (f sp) (f ep)
   where
     f (V2 x y) = V2 y x
 
-yIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
-{-# INLINE yIntercepts' #-}
-yIntercepts' s sp ep = map f $ xIntercepts' s (f sp) (f ep)
-  where
-    f (V2 x y) = V2 y x
-
 -- consider using: at x . non mempty . at y . non mempty <>~ a
 zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m)
 {-# INLINE zoneMonoid #-}