Fix glassLesson room

src/Dodge/Floor.hs

@@ -34,6 +34,7 @@ import System.Random
 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[AnoApplyInt 0 startRoom]
+    , [SpecificRoom $ glassLesson]
 --    , [SpecificRoom $ fmap (return . PassDown) longRoom]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
     , [SpecificRoom randomChallenges]

src/Dodge/Room.hs

@@ -17,6 +17,7 @@ module Dodge.Room
     , module Dodge.Room.Start
     , module Dodge.Room.Boss
     , module Dodge.Room.Treasure
+    , module Dodge.Room.GlassLesson
     ) where
 import Dodge.Room.Room
 import Dodge.Room.RoadBlock
@@ -35,3 +36,4 @@ import Dodge.Room.Door
 import Dodge.Room.Airlock
 import Dodge.Room.LongDoor
 import Dodge.Room.LongRoom
+import Dodge.Room.GlassLesson

src/Dodge/Room/GlassLesson.hs

@@ -0,0 +1,60 @@
+module Dodge.Room.GlassLesson where
+import Dodge.RoomLink
+import Dodge.Creature
+import Dodge.LevelGen.Data
+import Dodge.RandomHelp
+import Dodge.Default.Wall
+import Dodge.Tree
+import Dodge.Placement.Instance
+--import Dodge.LevelGen.Data
+import Dodge.Room.Procedural
+import Dodge.Room.Corridor
+import Dodge.Room.Link
+import Dodge.Room.Door
+import Geometry
+import LensHelp
+
+import qualified Data.Set as S
+import Control.Monad.State
+--import Control.Monad.Loops
+import System.Random
+import Data.Tree
+
+-- TODO: partially combine a room tree into a room
+glassLesson :: RandomGen g => State g (SubCompTree Room)
+glassLesson = do
+    i <- takeOne [1,2,3]
+    corridors <- replicateM i $ PassDown <$> randomiseOutLinks corridor
+    return $ Node (PassDown botRoom) 
+        [ singleUseNone $ door & rmConnectsTo .~ S.singleton (LabLink 0)
+        , uppers
+        , treeFromPost (PassDown (door & rmConnectsTo .~ S.singleton (OnEdge East)) 
+            : corridors) $ UseAll door]
+  where 
+    uppers = Node (PassDown $ door & rmConnectsTo .~ S.singleton (LabLink 1)) 
+        [singleUseNone $ setInLinksPD (onBottomEdgeLeft . fst) topRoom]
+    botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1 
+        & rmLinks %~ (setInLinksByType (OnEdge West)
+            . addLabelLink 0 (onTopEdgeRight . _rlPos)
+            . addLabelLink 1 (onTopEdgeLeft  . _rlPos)
+            )
+    onTopEdgeRight (V2 x y) = x > 50 && y > 95
+    onTopEdgeLeft (V2 x y) = x < 50 && y > 95
+    onBottomEdgeLeft (V2 x y) = x < 50 && y < 5
+    topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1
+    botplmnts = 
+        [sPS    (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
+        ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
+        ,RandomPlacement $ takeOne
+            [ spanLightI (V2 160 (-20)) (V2 160 220)
+            , mntLS vShape (V2 180 200) (V3 160 180 50)
+            ]
+        ]
+    topplmnts = 
+        [windowLine (V2 100 200) (V2 100 0) 
+        ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
+        ,RandomPlacement $ takeOne
+            [ spanLightI (V2 160 (-20)) (V2 160 220)
+            , mntLS vShape (V2 180 200) (V3 160 180 50)
+            ]
+        ]

src/Dodge/Room/Room.hs

@@ -75,33 +75,6 @@ branchWith r ts = Node (PassDown r) $ return (UseAll door) : fmap (fmap PassDown
 manyDoors :: Int -> SubCompTree Room
 manyDoors i = treeFromPost (replicate i (PassDown door)) $ UseAll door
 
--- TODO: partially combine a room tree into a room
-glassLesson :: RandomGen g => State g (SubCompTree Room)
-glassLesson = do
-    i <- takeOne [1,2,3]
-    corridors <- replicateM i $ PassDown <$> randomiseOutLinks corridor
-    return $ Node (PassDown botRoom) [singleUseNone door,uppers, treeFromPost (PassDown door : corridors) $ UseAll door]
-  where 
-    uppers = Node (PassDown door) [singleUseNone topRoom]
-    botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1
-    topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1
-    botplmnts = 
-        [sPS    (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
-        ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
-        ,RandomPlacement $ takeOne
-            [ spanLightI (V2 160 0) (V2 160 220)
-            , mntLS vShape (V2 180 200) (V3 160 180 50)
-            ]
-        ]
-    topplmnts = 
-        [windowLine (V2 100 200) (V2 100 0) 
-        ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
-        --,sPS (V2 50 50) 0 putLamp
-        ,RandomPlacement $ takeOne
-            [ spanLightI (V2 160 (-20)) (V2 160 220)
-            , mntLS vShape (V2 180 200) (V3 160 180 50)
-            ]
-        ]
 
 glassSwitchBack :: RandomGen g => State g Room
 glassSwitchBack = do

src/Dodge/RoomLink.hs

@@ -21,9 +21,24 @@ restrictInLinks = over rmLinks . restrictLinkType InLink
 restrictOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room
 restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f
 
+addLabelLink :: Int -> (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
+addLabelLink i t = map f
+  where
+    f rl | t rl = rl & rlType %~ S.insert (LabLink i)
+         | otherwise = rl
+
+setOutLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
+setOutLinks = setLinkType OutLink
+
 setInLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
 setInLinks = setLinkType InLink
 
+setInLinksByType :: RoomLinkType -> [RoomLink] -> [RoomLink]
+setInLinksByType lt = setInLinks (\rl -> lt `S.member` _rlType rl)
+
+setOutLinksByType :: RoomLinkType -> [RoomLink] -> [RoomLink]
+setOutLinksByType lt = setOutLinks (\rl -> lt `S.member` _rlType rl)
+
 setLinkType :: RoomLinkType -> (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
 setLinkType rlt f = map g
   where