Fix pathing for zChasm

src/Dodge/Room/Path.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE TupleSections #-}
-module Dodge.Room.Path (linksDAGToPath) where
+module Dodge.Room.Path (linksDAGToPath,addNodesCrossing) where
 
+import Linear
+import Data.Maybe
 import Control.Lens
 import Data.Function (on)
 import Data.List
@@ -16,3 +18,14 @@ linksDAGToPath lnks xs
     ys = lnks <&> _rlPos
     subpth = foldMap doublePairSet xs
     linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ S.map fst subpth)
+
+addNodesCrossing :: (Point2,Point2) -> S.Set (Point2,Point2) -> S.Set (Point2,Point2) 
+addNodesCrossing (x,y) = g . foldMap f
+  where
+    g (xs,m) = h xs <> m
+    f (a,b) = fromMaybe (mempty,S.singleton (a,b)) $ do
+        i <- intersectSegSeg x y a b
+        return (S.singleton i, S.fromList [(a,i),(i,b)])
+    h is | null is = mempty
+         | otherwise = let js = sortOn (distance x) $ S.toList is
+                in S.fromList . zip js $ tail js

src/Dodge/Room/Procedural.hs

@@ -45,17 +45,15 @@ roomRect x y xn yn =
         { _rmPolys = [rectNSWE y 0 0 x]
         , _rmLinks = lnks
         , _rmName = "rect"
-        , _rmPath = pth
+        , _rmPath = linksDAGToPath lnks $ latticeXsYs xs ys
         , _rmPos = gridRoomPos xs ys
---        , _rmPos = map makeonpos (grid xs ys) 
---            <> map makeoffpos (grid (mids xs) (mids ys))
         , _rmPmnts = []
         , _rmBound = [rectNSWE (y + 5) (-5) (-5) (x + 5)]
         , _rmFloor =
             Tiled
                 [ Tile
                     { _tilePoly = rectNSWE y 0 0 x
-                    , _tileZero = V2 0 0
+                    , _tileZero = 0
                     , _tileTangentPos = V2 baseFloorTileSize 0
                     , _tileArrayZ = 16
                     }
@@ -76,7 +74,6 @@ roomRect x y xn yn =
     ys = take (yn + 1) [0,yd..] & each +~ 20
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
-    pth = linksDAGToPath lnks $ latticeXsYs xs ys
     horilnks y' a e = xs <&> \x' -> RoomLink (rlt e) (V2 x' y') a
     vertlnks x' a e = ys <&> \y' -> RoomLink (rlt e) (V2 x' y') a
     rlt e = S.fromList [OnEdge e, InLink, OutLink]
@@ -88,28 +85,7 @@ roomRect x y xn yn =
         <> imap (g West) slnks
         <> imap (g South) elnks
         <> imap (g South) wlnks
-    g c xi ln = ln 
-        & rlType <>~ S.fromList [FromEdge c xi,FromEdge (revCard c) (xn - xi)]
-    grid as bs = [(V2 x' y', (xi,yi)) | (x',xi) <- zip as [0..], (y',yi) <- zip bs [0..]]
-    makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnGrid $ makerpedges a) 
-        (NotLink True) mempty
-    makerpedges (a, b) =
-        S.fromList
-            [ PathFromEdge South b
-            , PathFromEdge North (yn - b)
-            , PathFromEdge East (xn - a)
-            , PathFromEdge West a
-            ]
-    mids zs = zipWith (\a b -> 0.5 * (a + b)) zs $ tail zs
-    makeoffpos (p, a) = RoomPos 
-        p 0 (S.singleton $ RoomPosOffGrid $ makerpedges' a) (NotLink False) mempty
-    makerpedges' (a, b) =
-        S.fromList
-            [ PathFromEdge South b
-            , PathFromEdge North (yn - (b + 1))
-            , PathFromEdge East (xn - (a + 1))
-            , PathFromEdge West a
-            ]
+    g c xi = rlType <>~ S.fromList [FromEdge c xi,FromEdge (revCard c) (xn - xi)]
 
 gridRoomPos :: [Float] -> [Float] -> [RoomPos]
 gridRoomPos xs ys = map makeonpos (grid xs ys) <> map makeoffpos (grid (mids xs) (mids ys))

src/Dodge/Room/Tutorial.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.Room.Tutorial where
 
+import Dodge.Room.Path
 import Dodge.Room.Pillar
 import Dodge.Room.Boss
 import Dodge.Room.Tanks
@@ -47,15 +48,6 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
-        , tToBTree "cor" . return . cleatOnward <$> roomPillarsSquare
-        , corDoor
---        , return $ tToBTree "cor" $ return $ cleatOnward $ corridor & rmPmnts .~ mempty
---        , return $ tToBTree "cor" $ return $ cleatOnward $ roomGlassOctogon 200
---        , corDoor
---        , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , return $ tToBTree "cor" $ return $ cleatOnward airlock0
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
         , tToBTree "cor" . return . cleatOnward <$> (zChasm 25)
 --        , tToBTree "x" . return . cleatOnward <$> airlockSimple
 --        , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
@@ -173,6 +165,7 @@ zChasm z = do
     roomRectAutoLinks x y
         <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
         <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
+        <&> rmPath %~ addNodesCrossing (V2 0 (y/2),V2 x (y/2))
         <&> rmPmnts
             <>~ [ sps0 $ PutChasm (rectNSWE (y / 2 - z) 0 0 (x -50))
                 , sps0 $ PutChasm (rectNSWE y (y / 2 + z) 50 x)