Improve xIntercepts (still not perfect)

src/Dodge/Room/Airlock.hs

@@ -3,6 +3,7 @@
 {- Rooms that contain two doors and a switch alternating both.  -}
 module Dodge.Room.Airlock where
 
+import Dodge.Room.Path
 import Control.Lens
 import Control.Monad
 import Data.Maybe
@@ -164,12 +165,9 @@ airlockZ = do
         defaultRoom
             { _rmPolys =
                 [rectNSWE 120 0 0 180]
-            , _rmLinks = muout [(V2 0 30, pi / 2)] ++ muin [(V2 180 30, 1.5 * pi)]
-            , _rmPath = mempty
-            , --         [(V2 0 40,V2 40 0)
-              --         ,(V2 40 0,V2 0 40)
-              --         ]
-              _rmPmnts =
+            , _rmLinks = lnks
+            , _rmPath = linksGridToPath' lnks $ loopPairs $ rectNSWE 100 40 40 140
+            , _rmPmnts =
                 [ pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
                     \btid ->
                         airlockDoubleDoor
@@ -191,6 +189,7 @@ airlockZ = do
                 [rectNSWE 120 0 0 180]
             }
   where
+    lnks = muout [(V2 0 30, pi / 2)] ++ muin [(V2 180 30, 1.5 * pi)]
     col = dim $ dim $ bright red
     l1 = 61
     l2 = 61

src/Dodge/Room/Path.hs

@@ -4,6 +4,7 @@ module Dodge.Room.Path (
     makeGrid,
     createPathGrid,
     gridPoints'',
+    linksGridToPath',
 ) where
 
 import Control.Lens
@@ -33,11 +34,18 @@ createPathGrid rm = rm & rmPath .~ linksGridToPath (_rmLinks rm) filterGrid
             <*> L.premap sndV2 L.minimum
             <*> L.premap sndV2 L.maximum
 
+-- assumes subpth is symmetric
 linksGridToPath :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
 linksGridToPath lnks subpth = S.fromList subpth <> foldMap (linkClosest . (^. rlPos)) lnks
   where
     linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
 
+linksGridToPath' :: Foldable f => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2)
+linksGridToPath' lnks subpth' = subpth <> foldMap (linkClosest . (^. rlPos)) lnks
+  where
+    subpth = foldMap doublePairSet subpth'
+    linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ S.map fst subpth)
+
 testCrossWalls :: [(Point2, Point2)] -> (Point2, Point2) -> Bool
 testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls
 

src/Dodge/Room/Tutorial.hs

@@ -44,6 +44,11 @@ tutAnoTree = do
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
         , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
         , return $ tToBTree "cor" $ return $ cleatOnward corridor
         , tToBTree "asdf" . return . cleatOnward <$> airlockZ
         --, return . tToBTree "asdf" . return . cleatOnward $ airlockCrystal