Improve some door placement

src/Dodge/Placement/PlaceSpot.hs

@@ -6,6 +6,7 @@
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where
 
+import Dodge.Placement.PlaceSpot.Block
 import Control.Monad.State
 import Data.Bifunctor
 import Data.Foldable
@@ -16,7 +17,6 @@ import Dodge.Base.NewID
 import Dodge.Data.GenWorld
 import Dodge.Default.Wall
 import Dodge.Path
-import Dodge.Placement.PlaceSpot.Block
 import Dodge.Placement.PlaceSpot.TriggerDoor
 import Dodge.Placement.Shift
 import Dodge.ShiftPoint
@@ -134,7 +134,7 @@ placeSpotID rid ps pt w = case pt of
     PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
     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 isauto eo f l p1 p2 -> plDoor isauto eo f l (pashift p1) (pashift p2) w
+    PutDoor isauto f l p1 p2 -> plDoor isauto f l (pashift p1) (pashift p2) w
     PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
     PutSlideDr isauto wl dr eo off a b ->
         plSlideDoor isauto wl dr eo off (doShift a) (doShift b) w
@@ -180,9 +180,9 @@ placeWallPoly qs wl w
     | otherwise = error "tried to place wall poly with too few points"
 
 addPane :: Wall -> World -> (Point2, Point2) -> World
-addPane wl w l =
-    w & plNew (cWorld . lWorld . walls) wlID (wl & wlLine .~ l)
-        & uncurry (obstructPathsCrossing (S.fromList [WallObstacle WallNotAutoOpen])) l
+addPane wl w l = insertWall (wl & wlLine .~ l & wlID .~ i) w
+  where
+    i = IM.newKey $ w ^. cWorld . lWorld . walls
 
 mvProp :: Point2 -> Float -> Prop -> Prop
 mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
@@ -211,7 +211,7 @@ plMachine ::
 plMachine wallpoly mc mitm p rot gw =
     ( mcid
     , gw & tolw . machines . at mcid ?~ themc
-        & tolw . walls %~ placeMachineWalls wallpoly mcid wlid
+        & gwWorld %~ placeMachineWalls wallpoly mcid wlid
         & tolw %~ maybe id placeturretitm mitm
     )
   where
@@ -227,15 +227,10 @@ plMachine wallpoly mc mitm p rot gw =
         itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
         itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid
 
--- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
-placeMachineWalls :: [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
-placeMachineWalls poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
+placeMachineWalls :: [Point2] -> Int -> Int -> World -> World
+placeMachineWalls poly mcid = insertStructureWalls MachinePart baseWall poly mcid
   where
-    f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
-    baseWall =
-        defaultMachineWall
-            & wlStructure . wsMachine .~ mcid
-            & wlTouchThrough .~ True
+    baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid
 
 mvLS :: Point3 -> Float -> LightSource -> LightSource
 mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -2,16 +2,18 @@
 module Dodge.Placement.PlaceSpot.Block (
     plBlock,
     plLineBlock,
+    insertWall,
+    insertStructureWalls,
 ) where
 
-import Dodge.Wall.Pathing
-import qualified Data.Set as S
 import Control.Lens
 import qualified Data.IntSet as IS
 import Data.List
+import qualified Data.Set as S
 import Dodge.Base
 import Dodge.Data.GenWorld
 import Dodge.Path
+import Dodge.Wall.Pathing
 import Geometry
 import qualified IntMapHelp as IM
 
@@ -26,15 +28,26 @@ plBlock ps bl wl w =
                     , _blShadows = []
                     , _blFootprint = ps
                     }
-            & gwWorld %~ insertWalls wls
+            & gwWorld %~ insertStructureWalls BlockPart wl ps blid i
   where
     blid = IM.newKey $ w ^. gwWorld . cWorld . lWorld . blocks
     i = IM.newKey $ w ^. gwWorld . cWorld . lWorld . walls
-    is = take (length ps) [i .. ]
+    is = take (length ps) [i ..]
+
+insertStructureWalls ::
+    (Int -> WallStructure) ->
+    Wall ->
+    [Point2] ->
+    Int ->
+    Int ->
+    World ->
+    World
+insertStructureWalls f wl ps sid wid = insertWalls wls
+  where
     wls =
         zipWith
-            (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid)
-            is
+            (\i xy -> wl & wlLine .~ xy & wlID .~ i & wlStructure .~ f sid)
+            [wid ..]
             (loopPairs ps)
 
 -- | Splits a line into many four cornered blocks.
@@ -107,6 +120,7 @@ insertWalls wls w = foldl' (flip insertWall) w wls
 
 insertWall :: Wall -> World -> World
 insertWall wl =
-    uncurry (obstructPathsCrossing (S.map WallObstacle $ getWallPathing wl))
+    uncurry
+        (obstructPathsCrossing (S.map WallObstacle $ getWallPathing wl))
         (_wlLine wl)
         . (cWorld . lWorld . walls . at (_wlID wl) ?~ wl)

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -4,6 +4,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor (
     updateDoorEdges,
 ) where
 
+import Dodge.Placement.PlaceSpot.Block
 import Data.List
 import qualified Data.Set as S
 import Dodge.Data.GenWorld
@@ -19,7 +20,6 @@ import Linear
 
 plDoor ::
     Bool ->
-    S.Set EdgeObstacle ->
     -- | Opening condition
     WdBl ->
     -- | Door positions, closed to open.
@@ -29,7 +29,7 @@ plDoor ::
     Point2A ->
     GenWorld ->
     (Int, GenWorld)
-plDoor isauto eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
+plDoor isauto cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
   where
     drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw))
     addDoor =
@@ -43,13 +43,15 @@ plDoor isauto eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld .
                 , _drLerp = 0
                 , _drFootPrint = IM.fromList . zip wlids $ wlps'
                 }
-    wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..]
+    wlids = take 4 [wlid..]
+    wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
     wlps' = rectanglePairs 9 0 (V2 l 0)
+    addWalls = insertStructureWalls (`DoorPart` isauto) defaultDoorWall 
+        (map fst wlps' & each %~ shiftPointBy p1) drid wlid
     --addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids
-    addWalls w' =
-        foldl' (addDoorWall isauto eo drid defaultDoorWall) w' $
-            zip wlids $
-                wlps' & each . each %~ shiftPointBy p1
+    --    foldl' (addDoorWall isauto eo drid defaultDoorWall) w' $
+    --        zip wlids $
+    --            wlps' & each . each %~ shiftPointBy p1
 
 addDoorWall ::
     Bool ->