Move towards allowing partial destruction of doors

src/Dodge/Data.hs

@@ -11,6 +11,7 @@ module Dodge.Data
     ( module Dodge.Data
     , module Dodge.Data.Material
     , module Dodge.Data.LoadAction
+    , module Dodge.Data.ForegroundShape
     , module Dodge.Data.Wall
     , module Dodge.Combine.Data
     , module Dodge.Distortion.Data
@@ -30,6 +31,7 @@ module Dodge.Data
     , module Dodge.Data.Room
     ) where
 import Dodge.Data.Room
+import Dodge.Data.ForegroundShape
 import Dodge.Data.LoadAction
 import Dodge.Data.Material
 import Dodge.Data.Wall
@@ -135,6 +137,7 @@ data World = World
     , _toPlaySounds         :: M.Map SoundOrigin Sound
     , _playingSounds        :: M.Map SoundOrigin Sound
     , _decorations          :: IM.IntMap Picture
+    , _shapes               :: IM.IntMap ForegroundShape
     , _foregroundShape      :: Shape
     , _corpses              :: IM.IntMap Corpse
     , _clickMousePos        :: Point2
@@ -1018,10 +1021,16 @@ data Door = Door
     , _drHP     :: Int
     , _drDeath  :: Door -> World -> World
     , _drSpeed  :: Float
+    , _drSupport :: Support
+    , _drPushes :: Maybe Int
     }
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)
 
+data Support = SupportsItself
+    | SupportedBy Int
+    | Unsupported
+
 data ActionPlan
     = Inanimate
     | ActionPlan
@@ -1381,7 +1390,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutLineBlock {_putWall :: Wall , _putWidth :: Float
         , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
-    | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
+    | PutSlideDr Bool Color Door Float Point2 Point2
+--    | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | RandPS (State StdGen PSType)
     | PutShape Shape

src/Dodge/Default/Door.hs

@@ -14,5 +14,7 @@ defaultDoor = Door
     , _drHP     = 10000
     , _drDeath  = const id
     , _drSpeed  = 1
+    , _drSupport = SupportsItself
+    , _drPushes  = Nothing
     }
 

src/Dodge/Initialisation.hs

@@ -41,5 +41,5 @@ initialWorld = defaultWorld
     }
 
 testStringInit :: World -> [String]
-testStringInit = map (show . _drStatus) . IM.elems . _doors
+--testStringInit = map (show . _drStatus) . IM.elems . _doors
---testStringInit = const [] 
+testStringInit = const [] 

src/Dodge/LevelGen/Data.hs

@@ -28,6 +28,9 @@ pContID ps pt = Placement 10 ps pt Nothing . contToIDCont
 psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
 psPtCont ps pt = Placement 10 ps pt Nothing . const
 
+ptCont :: PSType -> (Placement -> Maybe Placement) -> Placement
+ptCont = psPtCont (PS 0 0)
+
 psPt :: PlacementSpot -> PSType -> Placement
 psPt ps pt = Placement 10 ps pt Nothing (const . const Nothing)
 

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
+     = doorBetween pathing col cond soff a half speed
-    $ \pl1 -> Just $ doorbetween b half
+    $ \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
+doorBetween :: Bool -> Color -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
---    [x,y] -> \_ -> Just (pt0 (PutSlideDr pathing col cond soff x y speed) g)
+    (Placement -> Maybe Placement) -> Placement
---    (x:y:zs) -> foldr f g (zip (x:y:zs) (y:zs))
+doorBetween pathing col cond soff pa pb speed g = case divideLine 40 pa pb of
---      where
+    [x,y] -> ptCont (PutSlideDr pathing col adoor soff x y) g
---        f :: (Point2,Point2) -> (Placement -> Maybe Placement) -> (Placement -> Maybe Placement)
+    (x:y:zs) -> divideDoorPane Nothing pathing col cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
---        f (a,b) h = \pl -> Just (pt0 (PutSlideDr pathing col cond (soff - dist y pb) a b speed) h)
+    _ -> 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 
+    PutSlideDr  pth col dr off  a   b 
-                            -> plSlideDoor pth col f off (doShift a) (doShift b) spd w
+                            -> 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

src/Dodge/Room/LongDoor.hs

@@ -3,6 +3,7 @@
  -}
 module Dodge.Room.LongDoor where
 import Dodge.Data
+import Dodge.Default.Door
 import Dodge.Cleat
 import Dodge.RoomLink
 import Dodge.Base
@@ -45,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom
     , _rmPath   = []
     , _rmPmnts     = 
         [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
-            $ \btid -> jsps0J (PutSlideDr False col (cond' btid) 1 (V2 x 1) (V2 x h) wlSpeed)
+            $ \btid -> jsps0J (PutSlideDr False col (thedoor btid) 1 (V2 x 1) (V2 x h))
-            $ ps0 (PutSlideDr False col (cond' btid) 1 (V2 (-x) 1) (V2 (-x) h) wlSpeed)
+            $ ps0 (PutSlideDr False col (thedoor btid) 1 (V2 (-x) 1) (V2 (-x) h))
             $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight)))
             $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
         ]
@@ -68,7 +69,9 @@ twinSlowDoorRoom w h x = defaultRoom
         [rectNSWE h    0 (-w) w
         ,rectNSWE 20 (-h) (negate x) x
         ]
-    cond' btid w' = _btState (_buttons w' IM.! btid) /= BtOff
+    thedoor btid = defaultDoor
+        & drSpeed .~ wlSpeed
+        & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) /= BtOff)
     col = dim $ dim $ bright red
 
 twinSlowDoorChasers :: RandomGen g => State g Room

src/Dodge/Room/Procedural.hs

@@ -12,6 +12,7 @@ module Dodge.Room.Procedural
 import Dodge.Data
 import Dodge.Placement.Shift
 import Dodge.Default.Wall
+import Dodge.Default.Door
 --import Shape.Data
 import Dodge.PlacementSpot
 import Dodge.Placement.Instance
@@ -266,7 +267,9 @@ centerVaultRoom w h d = return $ defaultRoom
     col = dim $ dim $ bright red
     theDoor = 
         [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
-            $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 (-21) 0) (V2 0 0) 2)
+            $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2 (-21) 0) (V2 0 0))
-            $          sPS   (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2   21  0) (V2 0 0) 2)
+            $          sPS   (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2   21  0) (V2 0 0))
         ]
-    cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
+    thedoor btid = defaultDoor
+        & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) == BtOn)
+        & drSpeed .~ 2

src/Picture/Data.hs

@@ -13,6 +13,7 @@ data Verx = Verx
     , _vxLayer  :: !Layer
     , _vxShadNum  :: !ShadNum
     }
+  deriving (Eq,Ord,Show)
 --newtype LayNum  = LayNum  { _unLayNum :: Int }
 
 data Layer
@@ -22,7 +23,7 @@ data Layer
     | BloomNoZWrite
     | DebugLayer
     | FixedCoordLayer
-  deriving (Eq,Ord,Enum,Bounded)
+  deriving (Eq,Ord,Enum,Bounded,Show)
 
 layerNum :: Layer -> Int
 layerNum = fromEnum
@@ -30,6 +31,7 @@ numLayers :: Int
 numLayers = length [minBound::Layer .. maxBound]
 --TODO use synonyms for layer numbers
 newtype ShadNum = ShadNum { _unShadNum :: Int }
+  deriving (Eq,Ord,Show)
 polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum
 {-# INLINE polyNum #-}
 {-# INLINE polyzNum #-}

src/Shape/Data.hs

@@ -29,14 +29,17 @@ data ShapeObj = ShapeObj
     { _shType :: ShapeType 
     , _shVs :: [ShapeV]
     }
+  deriving (Eq,Ord,Show)
 
 newtype ShapeType = TopPrism Int
+  deriving (Eq,Ord,Show)
 
 -- edges are given by four consecutive points
 data ShapeV = ShapeV
     {_svPos :: Point3
     ,_svCol :: Point4
     }
+  deriving (Eq,Ord,Show)
 pairToSV :: (Point3,Point4) -> ShapeV
 {-# INLINE pairToSV #-}
 pairToSV = uncurry ShapeV