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