Commit before adding more debugging control

src/Dodge/Room/Airlock.hs

@@ -3,8 +3,6 @@
 {- Rooms that contain two doors and a switch alternating both.  -}
 module Dodge.Room.Airlock where
 
-import Dodge.Room.Foreground
-import ShapePicture
 import Control.Lens
 import Control.Monad
 import qualified Data.IntMap.Strict as IM
@@ -18,11 +16,13 @@ import Dodge.LevelGen.PlacementHelper
 import Dodge.LevelGen.Switch
 import Dodge.Placement.Instance
 import Dodge.Placement.Instance.Analyser
+import Dodge.Room.Foreground
 import Dodge.Room.Path
 import Dodge.RoomLink
 import Geometry
 import Picture
 import RandomHelp
+import ShapePicture
 
 -- | A passage with a switch that opens forward access while closing backwards access.
 airlock :: RandomGen g => State g Room
@@ -107,26 +107,35 @@ airlockDoubleDoor ::
     Point2A ->
     Point2A ->
     Maybe Placement
-airlockDoubleDoor cond l x1 y1 x2 y2 =
-    jspsJ 0 0 (putDoor cond l x1 y1) $
-        sPS 0 0 (putDoor cond l x2 y2)
+airlockDoubleDoor cond l x1 y1 x2 y2 = jsps0J (pd x1 y1) $ sps0 (pd x2 y2)
+  where
+    pd = putDoor cond l
 
 putDoor :: WdBl -> Float -> Point2A -> Point2A -> PSType
-putDoor cond l p1 p2 = PutDoor dr wl
+putDoor cond l p1 p2 = PutDoor dr defaultDoorWall
   where
-    wl = defaultDoorWall
     dr =
         defaultDoor
             & drTrigger .~ cond
             & drUpdate .~ DoorLerp 0.01
             & drZeroPos .~ p1
             & drOnePos .~ p2
-            & drFootPrint .~ IM.fromList (zip [0 ..] wlps')
-    wlps' = loopPairs $ mkRectangle 9 (V2 l 0)
+            & drFootPrint
+                .~ IM.fromDistinctAscList
+                    (zip [0 ..] (loopPairs $ mkRectangle 9 (V2 l 0)))
 
 airlockSimple :: RandomGen g => State g Room
 airlockSimple = do
-    light1 <- mntLightLnkCond $ PS (V2 90 120) 0
+    light1 <-
+        join $
+            takeOne
+                [ mntLightLnkCond $ PS (V2 90 120) 0
+                , mntLightLnkCond $ PS (V2 90 0) pi
+                , return $ spanLightI (V2 90 0) (V2 90 120)
+                , return $ spanLightI (V2 0 60) (V2 180 60)
+                , takeOne [30, 60, 90] <&> \x ->
+                    spanLightY (V2 90 (120 - x)) (V2 (90 - x) 120) (V2 (90 + x) 120) (V2 90 0)
+                ]
     return $
         defaultRoom
             { _rmPolys = [rectNSWE 120 0 0 180]
@@ -208,9 +217,11 @@ airlock90 =
             [ pContID
                 (PS (V2 120 120) (3 * pi / 4))
                 xSwitch
-                $ \btid -> jsps (V2 5 5) 0 $ putDoor (WdBlBtOn btid) l1 x1 y1
-                        & putDoorDoor . drMounts .~ themounts
---            , mntLS vShape (V2 35 35) (V3 70 70 50)
+                $ \btid ->
+                    jsps (V2 5 5) 0 $
+                        putDoor (WdBlBtOn btid) l1 x1 y1
+                            & putDoorDoor . drMounts .~ themounts
+                            --            , mntLS vShape (V2 35 35) (V3 70 70 50)
             ]
         , _rmBound =
             pure
@@ -223,10 +234,10 @@ airlock90 =
         , _rmName = "airlock90"
         }
   where
-    themounts = 
+    themounts =
         [ MountedLight (V3 hl hl 50) 150 0.5
-        , MountedLight (V3 hl (-hl) 50) 150 0.5
-        , MountedSPic . noPic $ thinHighBar 55 (V2 hl (-hl')) (V2 hl hl')
+        , MountedLight (V3 hl (- hl) 50) 150 0.5
+        , MountedSPic . noPic $ thinHighBar 55 (V2 hl (- hl')) (V2 hl hl')
         ]
     lnks = muout [(V2 0 40, pi / 2)] ++ muin [(V2 40 0, pi)]
     hl = 27.5
@@ -239,8 +250,9 @@ airlockCrystal :: Room
 airlockCrystal =
     defaultRoom
         { _rmPolys = [rectNSWE 140 0 0 40, switchcutout]
-        , _rmLinks = muout [(V2 20 130, 0)] ++ muin [(V2 20 0, pi)]
-        , _rmPath = mempty
+        , _rmLinks = lnks
+        , _rmPath = linksGridToPath' lnks 
+            $ loopPairs [V2 20 40, V2 100 70, V2 20 110]
         , _rmPmnts =
             [ pContID
                 (PS (V2 145 70) (pi / 2))
@@ -252,6 +264,7 @@ airlockCrystal =
         , _rmBound = [rectNSWE 120 20 0 40, switchcutout]
         }
   where
+    lnks = muout [(V2 20 130, 0)] ++ muin [(V2 20 0, pi)]
     switchcutout = orderPolygon $ map toV2 [(39, 20), (150, 60), (150, 80), (39, 120)]
     l1 = 55
     x1 = (0, pi / 2)

src/Dodge/Room/Tutorial.hs

@@ -51,10 +51,11 @@ tutAnoTree = do
 --        , 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
+        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+        , return $ tToBTree "cor" $ return $ cleatOnward airlockCrystal
 --        , tToBTree "x" . return . cleatOnward <$> airlockSimple
 --        , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , tToBTree "lastun" . return . cleatOnward <$> cenLasTur
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor