Move towards allowing partial destruction of doors

src/Dodge/Placement/Instance/Door.hs

@@ -5,6 +5,7 @@ module Dodge.Placement.Instance.Door
     , switchDoor -- not used 9/3/22
     ) where
 import Dodge.Data
+import Dodge.Default.Door
 --import Dodge.Base
 import Color
 import Geometry
@@ -12,6 +13,8 @@ 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
 
 putDoubleDoor :: Bool -> Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Placement
@@ -23,19 +26,33 @@ putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
     -> (Placement -> Placement -> Maybe Placement)
     -> Placement
 putDoubleDoorThen pathing col cond soff a b speed cont 
-    = doorbetween a half
-    $ \pl1 -> Just $ doorbetween b half
+     = doorBetween pathing col cond soff a half speed
+    $ \pl1 -> Just $ doorBetween pathing col cond soff b half speed
     $ \pl2 -> cont pl1 pl2
   where
-    doorbetween pa pb = pt0 $ PutSlideDr pathing col cond soff pa pb speed
     half = 0.5 *.* (a +.+ b)
 
---doorBetween pathing col cond soff pa pb speed g = case divideLine 80 pa pb of
---    [x,y] -> \_ -> Just (pt0 (PutSlideDr pathing col cond soff x y speed) g)
---    (x:y:zs) -> foldr f g (zip (x:y:zs) (y:zs))
---      where
---        f :: (Point2,Point2) -> (Placement -> Maybe Placement) -> (Placement -> Maybe Placement)
---        f (a,b) h = \pl -> Just (pt0 (PutSlideDr pathing col cond (soff - dist y pb) a b speed) h)
+doorBetween :: Bool -> Color -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
+    (Placement -> Maybe Placement) -> Placement
+doorBetween pathing col cond soff pa pb speed g = case divideLine 40 pa pb of
+    [x,y] -> ptCont (PutSlideDr pathing col adoor soff x y) g
+    (x:y:zs) -> divideDoorPane Nothing pathing col cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
+    _ -> undefined
+  where
+    adoor = defaultDoor
+        & drTrigger .~ cond
+        & drSpeed   .~ speed
+
+divideDoorPane :: Maybe Int -> Bool -> Color -> (World -> Bool) -> Float -> Float 
+    -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
+divideDoorPane mid pathing col cond soff speed ppairs g = case ppairs of
+    [p] -> ptCont (adoor p) $ g
+    (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) pathing col cond soff speed ps g
+    _ -> undefined
+  where
+    adoor (x,y) = PutSlideDr pathing col thedoor soff x y
+    thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
+        & drSupport .~ SupportedBy (fromJust mid)
 
 putAutoDoor :: Point2 -> Point2 -> Placement
 putAutoDoor a b = PlacementUsingPos (addZ 0 a)
@@ -51,6 +68,10 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeS
     $ \btid -> jsps0J (doorbetween btid dra drc)
     $          sps0   (doorbetween btid drb drc)
   where
-    doorbetween btid a b = PutSlideDr False col (cond btid) 1 a b 2
+    doorbetween btid a b = PutSlideDr False col thedoor 1 a b
+      where
+        thedoor = defaultDoor
+            & drTrigger .~ cond btid
+            & drSpeed   .~ 2
     drc = 0.5 *.* (dra +.+ drb)
     cond btid w' = _btState (_buttons w' IM.! btid) == BtOn

src/Dodge/Placement/PlaceSpot.hs

@@ -101,8 +101,8 @@ placeSpotID ps pt w = case pt of
     RandPS      rgn         -> evaluateRandPS rgn ps w
     PutDoor     col f   pss -> plDoor col f (map (bimap doShift doShift) pss) w
     PutCoord    cp          -> plNewID   coordinates (doShift cp) w
-    PutSlideDr  pth col f off  a   b spd 
-                            -> plSlideDoor pth col f off (doShift a) (doShift b) spd w
+    PutSlideDr  pth col dr off  a   b 
+                            -> plSlideDoor pth col dr off (doShift a) (doShift b) w
     PutBlock    bl wl  ps'  -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
                                     wl w
     PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -15,6 +15,7 @@ import qualified IntMapHelp as IM
 import Dodge.SoundLogic
 --import Dodge.LevelGen.LevelStructure
 
+--import Data.Maybe
 import Data.List
 import Control.Lens
 --import Data.Graph.Inductive hiding ((&))
@@ -106,27 +107,24 @@ doorMechanism dr w = case mvDir of
 plSlideDoor 
     :: Bool 
     -> Color 
-    -> (World -> Bool) 
+    -> Door 
     -> Float
     -> Point2 
     -> Point2 
-    -> Float 
     -> World
     -> (Int, World)
-plSlideDoor isPathable col cond shiftOffset a b speed gw 
+plSlideDoor isPathable col dr shiftOffset a b gw 
     = (drid, addDoorWalls gw & doors %~ addDoor)
   where
     drid = IM.newKey $ _doors gw
-    addDoor = IM.insert drid $ defaultDoor
+    addDoor = IM.insert drid $ dr
         { _drID = drid
         , _drWallIDs = IS.fromList wlids
         , _drStatus = DoorClosed
-        , _drTrigger = cond
         , _drMech   = doorMechanism
         , _drPos = (a,b)
         , _drOpenPos = (shiftLeft a,shiftLeft b)
         , _drClosePos = (a,b)
-        , _drSpeed = speed
         }
     addDoorWalls w' = foldl' (addDoorWall drid col isPathable) w' $ zip wlids pairs
     pairs = rectanglePairs 9 a b