Correct non-pushing of partially destroyed doors

src/Dodge/Block.hs

@@ -60,8 +60,16 @@ destroyDoor dr w = w
     & deleteWallIDs wlids
     & doors %~ IM.delete (_drID dr)
     & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
+    & stopPushing (_drPushes dr)
   where
     wlids = _drWallIDs dr
     awl = _walls w IM.! IS.findMin wlids
     pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
     ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
+
+stopPushing :: Maybe Int -> World -> World
+stopPushing mdrid w = fromMaybe w $ do
+    drid <- mdrid
+    dr <- w ^? doors . ix drid
+    return $ w & doors . ix drid . drMech .~ const id
+        & stopPushing (_drPushes dr)

src/Dodge/Data.hs

@@ -169,6 +169,7 @@ data World = World
     , _testFloat            :: Float
     }
 
+
 newtype GenParams = GenParams
     { _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape)
     }

src/Dodge/Data/ForegroundShape.hs

@@ -8,8 +8,8 @@ import Control.Lens
 data ForegroundShape = ForegroundShape
     { _fsID :: Int
     , _fsPos :: Point2
-    , _fsRot :: Float
-    , _fsPic :: SPic
+    , _fsDir :: Float
+    , _fsSPic :: SPic
     }
   deriving (Eq,Show,Ord)
 makeLenses ''ForegroundShape

src/Dodge/LevelGen.hs

@@ -12,6 +12,7 @@ import Dodge.Tree
 import Geometry.ConvexPoly
 --import Dodge.LevelGen.LevelStructure
 
+import Data.Foldable
 import System.Directory
 import System.Random
 import Control.Lens
@@ -26,9 +27,18 @@ generateWorldFromSeed i = do
     writeFile "log/aGeneratedRoomLayout" ""
     (roomList,bounds) <- layoutLevelFromSeed 0 i
     return $ saveLevelStartSlot 
+        $ postGenerationProcessing
         $ generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i}
         & roomClipping .~ bounds
 
+postGenerationProcessing :: World -> World
+postGenerationProcessing w = foldl' assignPushDoors w (_doors w)
+
+assignPushDoors :: World -> Door -> World
+assignPushDoors w dr = case dr ^?! drSupport of
+    SupportedBy i -> w & doors . ix i . drPushes .~ Just (_drID dr)
+    _ -> w
+
 layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly])
 layoutLevelFromSeed i seed = do
     let i' = i + 1

src/Dodge/Placement/Instance/Door.hs

@@ -13,7 +13,6 @@ import Dodge.LevelGen.Data
 import Dodge.Creature.Test
 import Dodge.LevelGen.Switch
 
-import Data.Maybe
 import Control.Lens
 import qualified Data.IntMap.Strict as IM
 
@@ -52,7 +51,7 @@ divideDoorPane mid pathing col cond soff speed ppairs g = case ppairs of
   where
     adoor (x,y) = PutSlideDr pathing col thedoor soff x y
     thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
-        & drSupport .~ SupportedBy (fromJust mid)
+        & drSupport .~ maybe SupportsItself SupportedBy mid
 
 putAutoDoor :: Point2 -> Point2 -> Placement
 putAutoDoor a b = PlacementUsingPos (addZ 0 a)

src/Dodge/Render/ShapePicture.hs

@@ -34,6 +34,7 @@ worldSPic cfig w =
     (extraShapes w, extraPics cfig w)
     <> foldMap (dbArg _prDraw) (filtOn _prPos _props)
     <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
+    <> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
     <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
     <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
     <> foldMap floorItemSPic (filtOn _flItPos _floorItems)