Start unifying door placement types

src/Dodge/Data/GenWorld.hs

@@ -53,6 +53,7 @@ data PSType
         }
     | PutWall {_pwPoly :: [Point2], _pwWall :: Wall}
     | PutSlideDr Door Wall Float Point2 Point2
+    | PutDoor' Door Wall
     | PutDoor WdBl Float Point2A Point2A
     | RandPS (State StdGen PSType)
     | PutForeground ForegroundShape
@@ -80,6 +81,7 @@ instance ShortShow PSType where
     shortShow PutWall {} = "PutWall"
     shortShow PutSlideDr {} = "PutSlideDr"
     shortShow PutDoor {} = "PutDoor"
+    shortShow PutDoor' {} = "PutDoor'"
     shortShow RandPS {} = "RandPS"
     shortShow PutForeground {} = "PutForeground"
     shortShow PutWorldUpdate {} = "PutWorldUpdate"

src/Dodge/DrWdWd.hs

@@ -1,5 +1,6 @@
 module Dodge.DrWdWd (updateDoor) where
 
+import Dodge.Door.DoorLerp
 import Dodge.LightSource
 import Data.Foldable
 import Dodge.Wall.Delete
@@ -49,9 +50,6 @@ doorLerp speed dr w = fromMaybe (mempty,w) $ do
             soundContinue (WallSound drid) (fst $ doDoorLerp dr x) slideDoorS (Just 1)
         | otherwise = id
 
-doDoorLerp :: Door -> Float -> Point2A
-doDoorLerp dr = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos)
-
 destroyDoor :: Door -> World -> (S.Set Int2, World)
 destroyDoor dr w =
     (is,w

src/Dodge/Placement/PlaceSpot.hs

@@ -135,9 +135,9 @@ placeSpotID rid ps pt w = case pt of
     PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
     RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
     PutDoor f l p1 p2 -> plDoor f l (pashift p1) (pashift p2) w
+    PutDoor' dr wl -> plDoor' (dr & drZeroPos %~ pashift & drOnePos %~ pashift) wl w
+    PutSlideDr wl dr off a b -> plSlideDoor wl dr off (doShift a) (doShift b) w
     PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
-    PutSlideDr wl dr off a b ->
-        plSlideDoor wl dr off (doShift a) (doShift b) w
     PutBlock bl wl ps' ->
         plBlock
             (map doShift ps')

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -1,8 +1,10 @@
 module Dodge.Placement.PlaceSpot.TriggerDoor (
+    plDoor',
     plDoor,
     plSlideDoor,
 ) where
 
+import Dodge.Door.DoorLerp
 import Dodge.Data.GenWorld
 import Dodge.Default.Door
 import Dodge.Default.Wall
@@ -14,11 +16,35 @@ import qualified IntMapHelp as IM
 import LensHelp
 import Linear
 
+plDoor' ::
+    Door ->
+    Wall ->
+    GenWorld ->
+    (Int, GenWorld)
+plDoor' dr wl gw = 
+    ( drid
+    , over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors . at drid ?~ newdr
+    -- carefull with the ordering of addWalls
+    )
+  where
+    isauto = case dr ^. drTrigger of
+        WdBlCrFilterNearPoint{} -> True
+        _ -> False
+    drid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . doors
+    wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
+    pps = IM.elems $ dr ^. drFootPrint
+    newdr = dr & drID .~ drid & drFootPrint .~ IM.fromList (zip [wlid ..] pps)
+    lerposa = doDoorLerp dr (dr ^. drLerp)
+    addWalls =
+        insertStructureWalls
+            (`DoorPart` isauto)
+            wl
+            (map fst pps & each %~ shiftPointBy lerposa)
+            drid
+            wlid
+
 plDoor ::
-    -- | Opening condition
     WdBl ->
-    -- | Door positions, closed to open.
-    -- Bumped out up and down by 9, not widened
     Float ->
     Point2A ->
     Point2A ->
@@ -55,32 +81,6 @@ plDoor cond l p1 p2 gw =
             drid
             wlid
 
---addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids
---    foldl' (addDoorWall isauto eo drid defaultDoorWall) w' $
---        zip wlids $
---            wlps' & each . each %~ shiftPointBy p1
-
---addDoorWall ::
---    Bool ->
---    S.Set EdgeObstacle ->
---    Int ->
---    Wall ->
---    World ->
---    (Int, (Point2, Point2)) ->
---    World
---addDoorWall isauto eo drid wl w (wlid, wlps) =
---    w'
---        & cWorld . lWorld . walls
---            %~ IM.insert
---                wlid
---                wl
---                    { _wlLine = wlps
---                    , _wlID = wlid
---                    , _wlStructure = DoorPart drid isauto
---                    }
---  where
---    w' = uncurry (obstructPathsCrossing eo) wlps w
-
 plSlideDoor ::
     Door ->
     Wall ->
@@ -90,7 +90,6 @@ plSlideDoor ::
     GenWorld ->
     (Int, GenWorld)
 plSlideDoor dr wl shiftOffset a b gw =
-    --(drid, over gwWorld addDoorWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor)
     (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor)
   where
     isauto = case dr ^. drTrigger of
@@ -118,4 +117,3 @@ plSlideDoor dr wl shiftOffset a b gw =
             (map fst pairs)
             drid
             wlid
---    addDoorWalls w' = foldl' (addDoorWall isauto eo drid wl) w' $ zip wlids pairs

src/Dodge/Room/Airlock.hs

@@ -3,6 +3,9 @@
 {- Rooms that contain two doors and a switch alternating both.  -}
 module Dodge.Room.Airlock where
 
+import Dodge.LevelGen.DoorPane
+import Dodge.Default.Door
+import qualified Data.IntMap.Strict as IM
 import Dodge.Default.Wall
 import Dodge.Room.Path
 import Control.Lens
@@ -107,8 +110,20 @@ airlockDoubleDoor ::
     Point2A ->
     Maybe Placement
 airlockDoubleDoor p1 p2 cond l1 x1 y1 l2 x2 y2 =
-    jspsJ p1 0 (PutDoor cond l1 x1 y1) $
-        sPS p2 0 (PutDoor cond l2 x2 y2)
+    jspsJ p1 0 (putDoor cond l1 x1 y1) $
+        sPS p2 0 (putDoor cond l2 x2 y2)
+
+putDoor :: WdBl -> Float -> Point2A -> Point2A -> PSType
+putDoor cond l p1 p2 = PutDoor' dr wl
+  where
+    wl = defaultDoorWall
+    dr = defaultDoor
+        & drTrigger .~ cond
+        & drUpdate .~ DoorLerp 0.01
+        & drZeroPos .~ p1
+        & drOnePos .~ p2
+        & drFootPrint .~ IM.fromList (zip [0..] $ wlps')
+    wlps' = rectanglePairs 9 0 (V2 l 0)
 
 airlockSimple :: Room
 airlockSimple =

src/Dodge/Room/Tutorial.hs

@@ -48,10 +48,11 @@ tutAnoTree = do
 --        , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , tToBTree "lastun" . return . cleatOnward <$> cenLasTur
+--        , tToBTree "lastun" . return . cleatOnward <$> cenLasTur
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward airlockSimple
         , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor