Add files

src/Dodge/Door.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE LambdaCase #-}
+
+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
+import Dodge.Zoning.Pathing
+import Geometry.Data
+import LensHelp
+import Linear
+import Picture.Data
+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
+        , foldl' (doDoorMount (doDoorLerp dr (dr ^. drLerp))) w (dr ^. drMounts)
+        )
+
+doDoorMount :: Point2A -> World -> MountedObject -> World
+doDoorMount pa w = \case
+    MountedLight p r c ->
+        w & cWorld . lWorld . lights .:~ LSParam (p & _xy %~ shiftPointBy pa) r c
+    MountedSPic x ->
+        w & cWorld . lWorld . tempSPic
+            <>~ ( x & _1 . each . sfVs . each . _xy %~ shiftPointBy pa
+                    & _2 . each . vxPos . _xy %~ shiftPointBy pa
+                )
+
+doorLerp :: Float -> Door -> World -> (S.Set Int2, World)
+doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do
+    x <- newlerp
+    let ps = wlposs x
+        ps' = wlposs (dr ^. drLerp)
+        is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) (ps <> ps')
+    -- it seems possible that this will miss some paths: we don't add zones for the
+    -- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
+    return
+        ( is
+        , domounts x $
+            f x
+                & playSound x
+                & cWorld . lWorld . doors . ix drid . drLerp .~ x
+        )
+  where
+    domounts x w' = foldl' (doDoorMount (doDoorLerp dr x)) w' (dr ^. drMounts)
+    f = ifoldl' (flip . moveWallID) w . wlposs
+    wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
+    clerp = dr ^. drLerp
+    newlerp
+        | toOpen && clerp < 1 = Just . min 1 $ clerp + speed
+        | clerp > 0 && not toOpen = Just . max 0 $ clerp - speed
+        | otherwise = Nothing
+    toOpen = doWdBl (_drTrigger dr) w
+    drid = _drID dr
+    playSound x
+        | _drPushedBy dr == PushesItself =
+            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/Door/DoorLerp.hs

@@ -0,0 +1,9 @@
+module Dodge.Door.DoorLerp (doDoorLerp) where
+
+import Dodge.ShiftPoint
+import Dodge.Data.Door
+import Geometry.Data
+import Control.Lens
+
+doDoorLerp :: Door -> Float -> Point2A
+doDoorLerp dr = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos)

src/Dodge/Door/PutSlideDoor.hs

@@ -0,0 +1,20 @@
+module Dodge.Door.PutSlideDoor (putSlideDr) where
+
+import ListHelp
+import Dodge.LevelGen.DoorPane
+import Control.Lens
+import Geometry.Vector
+import qualified Data.IntMap.Strict as IM
+import Dodge.Data.GenWorld
+import Geometry.Data
+import Linear
+
+putSlideDr :: Door -> Wall -> Float -> Point2 -> Point2 -> PSType
+putSlideDr dr wl x a b = PutDoor thedr wl
+  where
+    c = a + (a - b) + x *^ normalizeV (b - a)
+    thedr =
+        dr & drUpdate . drLerpSpeed %~ (/ distance a c)
+           & drZeroPos .~ (a, 0)
+           & drOnePos .~ (c, 0)
+           & drFootPrint .~ IM.fromList (zip [0..] $ loopPairs (mkRectangle 9 (b - a)))

src/Dodge/Wall/Pathing.hs

@@ -0,0 +1,19 @@
+module Dodge.Wall.Pathing (getWallPathing) where
+
+import qualified Data.Set as S
+import Dodge.Data.Wall
+import Control.Lens
+
+getWallPathing :: Wall -> S.Set WallFlag
+getWallPathing wl = f . g . h $ mempty
+  where
+    h = case wl ^. wlStructure of 
+        StandaloneWall -> S.insert WallNotDestrucable
+        _ | wl ^. wlMaterial == Crystal -> S.insert WallNotDestrucable
+        _ -> id
+    g = case wl ^? wlStructure . wsIsAutoDoor of 
+        Just True -> id
+        _ -> S.insert WallNotAutoOpen
+    f = case wl ^. wlOpacity of
+        Opaque {} -> S.insert WallBlockVisibility
+        _ -> id