Add log when generating layout

src/Dodge/Annotation.hs

@@ -37,8 +37,9 @@ padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs
     thetree = do
         thecor <- shuffleLinks corridor
         takeOne
-            [ return (UseAll door)
+            [ (return (UseAll door),TreeSubLabelling "door" Nothing)
-            , treeFromPost [PassDown door, PassDown thecor] (UseAll door)
+            , (treeFromPost [PassDown door, PassDown thecor] (UseAll door)
+                ,TreeSubLabelling "twoDoors" Nothing)
             ]
 
 {- Add one to three corridors between each parent-child link of a tree of annotations.  -}
@@ -54,30 +55,34 @@ roomThenCorridor theRoom = fmap
     (shuffleLinks corridor)
 
 {- | Create a random room tree structure from a list of annotations.  -}
-anoToRoomTree :: [Annotation] -> State StdGen (SubCompTree Room,String)
+anoToRoomTree :: [Annotation] -> State StdGen (LabSubCompTree Room)
 anoToRoomTree anos = case anos of
     [AnoApplyInt i f] -> f i
-    [AnoApplyInt' i f str] -> f i <&> (,str)
+--    [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing)
-    _ -> fmap (,"") $ anoToRoomTree' anos
+    (SpecificRoom rt:_) -> rt
+    [PassthroughLockKeyLists i ls ks] -> do
+        (functionlockroom,randomitemidentity) <- takeOne ls
+        lr' <- functionlockroom i
+        ii <- randomitemidentity
+        let lr = fst lr'
+        keyroom' <- fromJust $ lookup ii ks
+        let keyroom = fst keyroom'
+        (return $ overwriteLabel 0 UseNone lr [keyroom]
+            ) <&> (,TreeSubLabelling ("PassthroughLockKeyLists-"++show ii) 
+                (Just $ treeFromPost [snd lr'] (snd keyroom'))
+                )
+    _ -> (,TreeSubLabelling "" Nothing) <$> anoToRoomTree' anos
 
 {- | Create a random room tree structure from a list of annotations.  -}
 anoToRoomTree' :: [Annotation] -> State StdGen (SubCompTree Room)
 anoToRoomTree' anos = case anos of
---    [AnoApplyInt i f] -> f i
     [ChainAnos ass] -> do
         rms <- mapM anoToRoomTree' ass
         return $ chainUses rms
-    [PassthroughLockKeyLists i ls ks] -> do
-        (functionlockroom,randomitemidentity) <- takeOne ls
-        lr <- functionlockroom i
-        ii <- randomitemidentity
-        keyroom <- fromJust $ lookup ii ks
-        return $ overwriteLabel 0 UseNone lr [keyroom]
     [OrAno as] -> do
         a <- takeOne as
         anoToRoomTree' a
     [Corridor] -> pure . UseAll <$> shuffleLinks corridor
-    (SpecificRoom rt:_) -> rt
     (BossAno cr : _) -> do
         br <- bossRoom cr
         branchRectWith . pure . fmap PassDown $ treeFromPost [corridor,corridor] br

src/Dodge/Annotation/Data.hs

@@ -14,15 +14,14 @@ data Annotation
     | Corridor
     | AirlockAno
     | OrAno [[Annotation]]
-    | SpecificRoom (State StdGen (SubCompTree Room))
+    | SpecificRoom (State StdGen (LabSubCompTree Room))
     | BossAno Creature
     | TreasureAno [Creature] [Item]
-    | AnoApplyInt Int (Int -> State StdGen (SubCompTree Room,String))
+    | AnoApplyInt Int (Int -> State StdGen (LabSubCompTree Room))
-    | AnoApplyInt' Int (Int -> State StdGen (SubCompTree Room)) String
     | AnoNewInt (Int -> State StdGen (SubCompTree Room))
     | PassthroughLockKeyLists Int 
-        [(Int -> State StdGen (SubCompTree Room), State StdGen CombineType)]
+        [(Int -> State StdGen (LabSubCompTree Room), State StdGen CombineType)]
-        [(CombineType, State StdGen (SubCompTree Room))]
+        [(CombineType, State StdGen (LabSubCompTree Room))]
 --    | SetLabel Int (State g Room)
 --    | UseLabel Int (State g Room)
     | ChainAnos [[Annotation]]

src/Dodge/Floor.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 --{-# OPTIONS_GHC -Wno-unused-imports #-}
 {- | The tree of rooms that make up a level. -}
 module Dodge.Floor
@@ -38,16 +39,18 @@ import System.Random
 initialAnoTree :: Tree [Annotation]
 initialAnoTree = padSucWithDoors $ treeFromTrunk 
     [[AnoApplyInt 0 startRoom]
-    , [SpecificRoom $ return . return . UseAll $ roomRectAutoLinks 400 400
+    , [SpecificRoom $ return (return . UseAll $ roomRectAutoLinks 400 400
         & rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit chaseCrit)
                 , spNoID anyUnusedSpot (PutCrit armourChaseCrit)
                 ]
+            , TreeSubLabelling "chaseCrit+armourChaseCrit rectRoom" Nothing)
     ]
 --    , [AnoApplyInt 100 healthTest]
-    , [SpecificRoom $ return . UseAll <$> tanksRoom [] []]
+    , [SpecificRoom ((return . UseAll <$> tanksRoom [] []) 
+        <&> (, TreeSubLabelling "empty tanksRoom" Nothing))]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
     , [SpecificRoom randomChallenges]
-    , [AnoApplyInt' 1 lasSensorTurretTest "lasSensorTurretTest"]
+    , [AnoApplyInt 1 lasSensorTurretTest]
 --    ,[SpecificRoom $ fmap singleUseAll roomCCrits]
 --    ,[AirlockAno]
 --    ,[Corridor]
@@ -88,11 +91,13 @@ initialAnoTree = padSucWithDoors $ treeFromTrunk
 --    ,[Corridor]
 --    ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
     ] 
-    $ treeFromPost [[Corridor,SpecificRoom $ pure . UseAll <$> randomFourCornerRoom []]] 
+    $ treeFromPost [[Corridor,SpecificRoom $ (pure . UseAll <$> randomFourCornerRoom []) 
-    [SpecificRoom $ fmap (pure . UseAll) (telRoomLev 1)]
+        <&>(,TreeSubLabelling "randomFourCornerRoom" Nothing )]] 
+    [SpecificRoom $ (fmap (pure . UseAll) (telRoomLev 1)) 
+        <&> (,TreeSubLabelling "telRoomLev" Nothing)]
 
 {- | A test level tree. -}
-initialRoomTree :: State StdGen (Tree (SubCompTree Room,String))
+initialRoomTree :: State StdGen (Tree (LabSubCompTree Room))
 initialRoomTree = mapM anoToRoomTree initialAnoTree
 --initialRoomTree :: State StdGen (Tree Room)
 --initialRoomTree = do

src/Dodge/LevelGen.hs

@@ -34,7 +34,7 @@ layoutLevelFromSeed i seed = do
     let g = mkStdGen seed
     let treecluster = evalState initialRoomTree g
     putStrLn "Room cluster layout:"
-    putStrLn $ drawTree $ fmap snd treecluster
+    putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
     let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
     putStrLn "Room layout (compact): "
     putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
@@ -55,6 +55,14 @@ layoutLevelFromSeed i seed = do
             let (seed',_) = random g
             layoutLevelFromSeed i' seed'
 
+drawTreeSubLabelling :: Tree TreeSubLabelling -> String
+drawTreeSubLabelling t = drawTree (fmap _topLabel t)
+    ++ concat
+    (map f $ flatten t)
+  where
+    f (TreeSubLabelling _ Nothing) = ""
+    f (TreeSubLabelling l (Just t')) = l ++ ":\n" ++ drawTreeSubLabelling t'
+
 reversePair :: (a,b) -> (b,a)
 reversePair (a,b) = (b,a)
 

src/Dodge/LockAndKey.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.LockAndKey where
 import Dodge.Data
 import Dodge.Tree
@@ -8,6 +9,7 @@ import Dodge.Creature
 import Dodge.Item.Craftable
 import Dodge.Item.Weapon.BulletGun.Rod
 import Dodge.Item
+import LensHelp
 --import Dodge.Item.Equipment
 
 import System.Random
@@ -18,7 +20,7 @@ bossKeyItems =
     [(return . UseAll <$> bossRoom autoCrit, takeOne [PISTOL])
     ]
 
-lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g CombineType ) ]
+lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabSubCompTree Room) , State g CombineType ) ]
 lockRoomKeyItems = 
     [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
     ,(sensorRoomRunPast Electrical, takeOne [STATICMODULE,SPARKGUN] )
@@ -31,7 +33,7 @@ lockRoomKeyItems =
     ,(keyCardRoomRunPast 0, return (KEYCARD 0))
     ]
 
-itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]
+itemRooms :: RandomGen g => [(CombineType, State g (LabSubCompTree Room))]
 itemRooms = 
     [ (LAUNCHER , join $ takeOne 
         [corridorBoss launcherCrit
@@ -95,9 +97,10 @@ someCrits = do
 --    return $ roomsContaining crits its
 
 
-corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room)
+corridorBoss :: RandomGen g => Creature -> State g (LabSubCompTree Room)
 corridorBoss cr = do
     endroom <- bossRoom cr
-    return $ treeFromPost (replicate 5 $ PassDown corridor) 
+    (return $ treeFromPost (replicate 5 $ PassDown corridor) 
                             (PassDown endroom)
+        ) <&> (,TreeSubLabelling "corridorBoss" Nothing)
 

src/Dodge/Room/Containing.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Containing where
 import Dodge.Data
 import Dodge.Tree
@@ -14,13 +15,13 @@ import Geometry
 import System.Random
 import Control.Monad.State
 
-roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (SubCompTree Room)
+roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabSubCompTree Room)
 roomsContaining crs its = do
     endroom <- join $ takeOne
         [ randomFourCornerRoomCrsIts crs its 
         , tanksRoom crs its
         ]
-    return $ treeFromPost [] $ UseAll endroom
+    (return $ treeFromPost [] $ UseAll endroom) <&> (,TreeSubLabelling "roomsContaining" Nothing)
 
 pedestalRoom :: RandomGen g => Item -> State g Room
 pedestalRoom it = do

src/Dodge/Room/Corridor.hs

@@ -59,6 +59,7 @@ corridorN = defaultRoom
     , _rmPath  = pth
     , _rmPmnts    = []
     , _rmBound = [ rectNSWE 50 30 0 40 ]
+    , _rmName = "corridorN"
     }
     where lnks = [uncurry outLink (V2 20 70  ,0)
                  ,uncurry inLink (V2 20 10  ,pi)
@@ -88,6 +89,7 @@ tEast = defaultRoom
     , _rmPath  = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
     , _rmPmnts    = []
     , _rmBound = [ rectNSWE 70 10 0 40 ]
+    , _rmName = "tEast"
     }
   where 
     lnks =
@@ -109,6 +111,7 @@ tWest = defaultRoom
     , _rmPath  = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks
     , _rmPmnts    = []
     , _rmBound = [ rectNSWE 70 10 0 40 ]
+    , _rmName = "tWest"
     }
   where 
     lnks =

src/Dodge/Room/GlassLesson.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.GlassLesson where
 import Dodge.RoomLink
 import Dodge.Creature
@@ -54,7 +55,7 @@ glassLesson = do
             , mntLS vShape (V2 180 200) (V3 160 180 50)
             ]
         ]
-glassLessonRunPast :: RandomGen g => State g (SubCompTree Room)
+glassLessonRunPast :: RandomGen g => State g (LabSubCompTree Room)
-glassLessonRunPast = f <$> glassLesson
+glassLessonRunPast = (f <$> glassLesson) <&> (,TreeSubLabelling "glassLessonRunPast" Nothing)
   where
     f (Node r rs) = Node r $ return (UseLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs

src/Dodge/Room/LasTurret.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.LasTurret where
 import Dodge.LevelGen.Data
 import Dodge.PlacementSpot
@@ -72,14 +73,14 @@ lightSensByDoor outplid rm = rm
     covershape = rectNSEW 10 (-10) 20 (-20)
     sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
 
-keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (SubCompTree Room)
+keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (LabSubCompTree Room)
 keyCardRoomRunPast keyid rmid = do
     cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
     let doorroom = triggerDoorRoom rmid
-    return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) 
+    (return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) 
         [ treeFromPost [PassDown doorroom] (UseAll door)
         , treeFromPost [PassDown door]     (UseLabel 0 corridor)
-        ]
+        ]) <&> (,TreeSubLabelling "keyCardRoomRunPast" Nothing)
 
 keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
 keyCardAnalyserByDoor keyid = analyserByDoor 
@@ -133,20 +134,22 @@ healthTest n = do
         ,PassDown $ corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100))
         ,PassDown cenroom,PassDown doorroom] (UseAll door)
 
-lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room)
+lasSensorTurretTest :: RandomGen g => Int -> State g (LabSubCompTree Room)
 lasSensorTurretTest n = do
     cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
     let doorroom = triggerDoorRoom n
-    return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
+    return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
+        , TreeSubLabelling "lasSensorTurretTest" Nothing
+        )
 
-lasCenSensEdge :: RandomGen g => Int -> State g (SubCompTree Room)
+lasCenSensEdge :: RandomGen g => Int -> State g (LabSubCompTree Room)
 lasCenSensEdge n = do
     cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
     let doorroom = triggerDoorRoom n
-    return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) 
+    (return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) 
         [ treeFromPost [PassDown doorroom] (UseAll door)
         , treeFromPost [PassDown door]     (UseLabel 0 corridor)
-        ]
+        ]) <&> (,TreeSubLabelling "lasCenSensEdge" Nothing)
 
 lasTunnel :: RandomGen g => Float -> State g Room
 lasTunnel y = do
@@ -183,12 +186,12 @@ lasTunnel y = do
         ]
 
 -- a y value of 400 is probably "unrunnable"
-lasTunnelRunPast :: RandomGen g => Float -> State g (SubCompTree Room)
+lasTunnelRunPast :: RandomGen g => Float -> State g (LabSubCompTree Room)
 lasTunnelRunPast y = do
     r <- lasTunnel y
     r1 <- takeOne [door,corridor]
     r2 <- takeOne [door,corridor]
-    return $ Node (PassDown r)
+    (return $ Node (PassDown r)
         [ singleUseAll r1
         , return (UseLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
-        ]
+        ]) <&> (,TreeSubLabelling "lasTunnelRunPast" Nothing)

src/Dodge/Room/LongDoor.hs

@@ -1,4 +1,4 @@
---{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections #-}
 {- | Rooms containing long doors, probably with a big reveal behind them.
  -}
 module Dodge.Room.LongDoor where
@@ -142,10 +142,10 @@ slowDoorRoom = do
     proom <- southPillarsRoom x y h
     addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
 
-slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room)
+slowDoorRoomRunPast :: RandomGen g => State g (LabSubCompTree Room)
 slowDoorRoomRunPast = do
     r <- slowDoorRoom
-    return $ treeFromTrunk [PassDown door] $ Node (PassDown r)
+    (return $ treeFromTrunk [PassDown door] $ Node (PassDown r)
         [ singleUseAll door
         , return (UseLabel 0 $ door & rmConnectsTo .~ S.member InLink)
-        ]
+        ] ) <&> (,TreeSubLabelling "slowDoorRoomRunPast" Nothing)

src/Dodge/Room/LongRoom.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.LongRoom where
 import Dodge.RoomLink
 import Dodge.Tree
@@ -48,10 +49,10 @@ longRoom = do
                 | crx <- [12.5,37.5,62.5] ] ++
         [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
 
-longRoomRunPast :: RandomGen g => State g (SubCompTree Room)
+longRoomRunPast :: RandomGen g => State g (LabSubCompTree Room)
 longRoomRunPast = do
     r <- longRoom
-    return $ treeFromTrunk [PassDown door]
+    (return $ treeFromTrunk [PassDown door]
         (Node (PassDown r)
             [ singleUseAll door
             --, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
@@ -60,3 +61,4 @@ longRoomRunPast = do
                 (UseLabel 0 door)
             ]
         )
+        ) <&> (,TreeSubLabelling "longRoomRunPast" Nothing)

src/Dodge/Room/Room.hs

@@ -130,14 +130,18 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen)
 
 -- So, the idea is to attach outer children to the bottommost right nodes
 -- inside an inner tree
-roomMiniIntro :: RandomGen g => State g (SubCompTree Room)
+roomMiniIntro :: RandomGen g => State g (LabSubCompTree Room)
 roomMiniIntro = do
     midroom <- join $ takeOne [miniTree2] --,glassLesson]
-    return $ chainUses [return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor]
+    (return $ chainUses 
+        [return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor]
+        ) <&> (,TreeSubLabelling "roomMiniIntro" Nothing)
 
 roomCenterPillar :: RandomGen g => State g Room
 roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) 
-    $ set rmPmnts plmnts $ roomRect 240 240 2 2
+    $ set rmPmnts plmnts 
+    $ set rmName "roomCenterPillar"
+    $ roomRect 240 240 2 2
   where 
     plmnts = 
         [ blockLine (V2 115 115) (V2 115 125)
@@ -196,7 +200,7 @@ weaponEmptyRoom = do
         $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
     return $ treeFromTrunk [PassDown corridor] (singleUseAll rm )
      
-weaponUnderCrits :: RandomGen g => Int -> State g (SubCompTree Room)
+weaponUnderCrits :: RandomGen g => Int -> State g (LabSubCompTree Room)
 weaponUnderCrits i = do
     let plmnts = 
             [--sPS (V2 20 0)   0 $ RandPS randFirstWeapon
@@ -204,23 +208,36 @@ weaponUnderCrits i = do
             ,sPS (V2 20 20) ( pi/2) randC1
             ]
         addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon)
-    let continuationRoom = treeFromTrunk 
+    let continuationRoom = treeFromTrunk
             [PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN] 
             (singleUseAll (set rmPmnts plmnts corridorN))
-    rcp <- roomCenterPillar 
+    rcp <- roomCenterPillar
     rmpils <- roomPillars 30 240 240 2 2
     deadEndRoom' <- takeOne
         [ addwpat (V2 120 20) rmpils
         , addwpat (V2 120 20) rcp]
     junctionRoom <- takeOne [PassDown tEast,PassDown tWest]
-    return $ treeFromTrunk 
+    let thetree = treeFromTrunk 
-        --[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
+            --[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
-        [PassDown corridorN
+            [PassDown corridorN
-        ,PassDown corridorN] 
+            ,PassDown corridorN] 
-                       $ Node junctionRoom
+                           $ Node junctionRoom
-                              [continuationRoom
+                                  [continuationRoom
-                              ,singleUseNone deadEndRoom'
+                                  ,singleUseNone deadEndRoom'
-                              ]
+                                  ]
+    return thetree  
+        <&> (, TreeSubLabelling ("weaponUnderCrits "++show i) (Just $ fmap composingNodeName thetree))
+
+composingNodeName :: ComposingNode Room -> TreeSubLabelling
+composingNodeName cn = case cn of
+    PassDown  rm -> f $ _rmName rm ++ "-PassDown"
+    SplitDown rm -> f $ _rmName rm ++ "-SplitDown"
+    UseAll    rm -> f $ _rmName rm ++ "-UseAll"
+    UseSome   is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome"
+    UseNone   rm -> f $ _rmName rm ++ "-UseNone"
+    UseLabel  i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-UseLabel"
+  where
+    f str = TreeSubLabelling str Nothing
 
 weaponBehindPillar :: RandomGen g => State g (SubCompTree Room)
 weaponBehindPillar  = do
@@ -285,18 +302,21 @@ deadEndRoom = defaultRoom
     , _rmPath  = []
     , _rmPmnts    = [sPS (V2 0 (-10)) 0 putLamp]
     , _rmBound = [rectNSWE 20 (-20) (-30) 30]
+    , _rmName = "deadEndRoom"
     }
   where 
     lnks = [(V2 0 30  ,0) ]
 {- A random Either tree with a weapon and melee monster challenge.  -}
-weaponRoom :: RandomGen g => Int -> State g (SubCompTree Room, String)
+weaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
 weaponRoom i = join $ takeOne 
-    [ weaponEmptyRoom      <&> (, "weaponEmptyRoom")
+    [ weaponEmptyRoom      <&> (,f "weaponEmptyRoom")
-    , weaponUnderCrits i<&> (, "weaponUnderCrits")
+    , weaponUnderCrits i
-    , weaponBehindPillar<&> (, "weaponBehindPillar")
+    , weaponBehindPillar<&> (,f "weaponBehindPillar")
-    , weaponBetweenPillars<&> (, "weaponBetweenPillars")
+    , weaponBetweenPillars<&> (,f "weaponBetweenPillars")
-    , weaponLongCorridor<&> (, "weaponLongCorridor")
+    , weaponLongCorridor<&> (,f "weaponLongCorridor")
     ]
+  where
+    f str = TreeSubLabelling str Nothing
 
 roomCCrits :: RandomGen g => State g Room
 roomCCrits = roomC 200 200
@@ -392,7 +412,7 @@ pistolerRoom = pillarGrid
         ]
             ++)
 
-shootingRange :: RandomGen g => State g (SubCompTree Room)
+shootingRange :: RandomGen g => State g (LabSubCompTree Room)
 shootingRange = do
     rm1 <- shootersRoom1 >>= randomiseAllLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
                         . restrictOutLinks  (\(V2 _ y,r) -> y > 200 && r /= 0)
@@ -402,7 +422,7 @@ shootingRange = do
     rm3 <- shootersRoom >>= randomiseAllLinks
             . restrictInLinks  (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
             . restrictOutLinks (\(_,r) -> r == 0)
-    return $ treeFromPost 
+    (return $ treeFromPost 
         [PassDown rm1
         ,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
             & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
@@ -411,6 +431,7 @@ shootingRange = do
             & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
         ] 
         (UseAll rm3)
+        ) <&> (,TreeSubLabelling "shootingRange" Nothing)
 
 spawnerRoom :: RandomGen g => State g (SubCompTree Room)
 spawnerRoom = do

src/Dodge/Room/SensorDoor.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.SensorDoor where
 import Dodge.LevelGen.Data
 import Dodge.PlacementSpot
@@ -41,14 +42,14 @@ sensorRoom senseType n = do
     let doorroom = triggerDoorRoom n
     return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
 
-sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (SubCompTree Room)
+sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabSubCompTree Room)
 sensorRoomRunPast dt n = do
     t <- sensorRoom dt n
-    return $ applyToSubforest [0] (++
+    (return $ applyToSubforest [0] (++
         [treeFromPost [PassDown $ door & rmConnectsTo .~ S.member InLink
             & rmName .~ "test"
         ] (UseLabel 0 corridor)]
-        ) t
+        ) t ) <&> (,TreeSubLabelling "sensorRoomRunPast" Nothing)
         --[return $ UseLabel 0 $ door & rmConnectsTo .~ S.member InLink]
 
 sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement

src/Dodge/Room/Start.hs

@@ -49,25 +49,27 @@ powerFakeout = do
                 ,PassDown keyholeCorridor,PassDown corridor])
         `treeFromPost` UseAll door
 
-startRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
+startRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
-startRoom i = join $ uncurry takeOneWeighted $ unzip 
+startRoom i = (join $ uncurry takeOneWeighted $ unzip 
     [ (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) 
-            <&> (,"chainUses <$> sequence [powerFakeout,weaponRoom i]"))
+            <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
-    , (,) one (rezBoxesWp <&> (, "rezBoxesWp"))
+    , (,) one (rezBoxesWp <&> (,TreeSubLabelling "rezBoxesWp" Nothing))
     , (,) one (rezBoxThenWeaponRoom i)
-    , (,) one (rezBoxesWpCrit <&> (,"rezBoxesWpCrit"))
+    , (,) one (rezBoxesWpCrit <&> (,TreeSubLabelling "rezBoxesWpCrit" Nothing))
-    , (,) one (runPastStart i <&> (,"runPastStart " ++ show i))
+    , (,) one (runPastStart i <&> (,TreeSubLabelling ("runPastStart " ++ show i) Nothing))
-    , (,) one (startCrafts >>= roomsContaining [] >>= rezBoxThenRooms <&> 
+    , (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&> 
-        (,"startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"))
+        (,TreeSubLabelling "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" Nothing))
-    ]
+    ])
+    <&> over (_2 . topLabel) ("startRoom:"++)
   where
+    roomsContaining' a b = fst <$> roomsContaining a b
     one = 1::Float
-randomChallenges :: RandomGen g => State g (SubCompTree Room)
+randomChallenges :: RandomGen g => State g (LabSubCompTree Room)
-randomChallenges = join $ takeOne
+randomChallenges = join (takeOne
-    [fmap (return . UseAll) doubleCorridorBarrels
+    [fmap (return . UseAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
     ,shootingRange
-    ,fmap (return . UseAll) twinSlowDoorChasers
+    ,fmap (return . UseAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
-    ]
+    ]) <&> (over (_2 . topLabel) ("randomChallenges:"++))
 
 runPastStart :: RandomGen g => Int -> State g (SubCompTree Room)
 runPastStart i = do
@@ -83,15 +85,15 @@ rezBoxStart = do
 rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
 rezBoxesThenWeaponRoom i = do
     rboxes <- rezBoxes
-    wroom  <- fmap fst $ weaponRoom i
+    wroom  <- fst <$> weaponRoom i
     return (rboxes `passUntilUseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
 
-rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
+rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
 rezBoxThenWeaponRoom i = do
     rcol <- rezColor
     (wroom,wroomname) <- weaponRoom i
-    return $ (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom
+    return (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom
-         , "rezBoxThenWeaponRoom "++ show i ++ ":" ++ wroomname)
+         , TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname))
 
 rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room)
 rezBoxThenRoom r = do

src/Dodge/Tree/Compose.hs

@@ -35,7 +35,7 @@ overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
   where
     islabel (UseLabel j _) | i == j = True
     islabel _ = False
-    update (Node cr _) = Node (f $ _unCompose cr) ts
+    update (Node x _) = Node (f $ _unCompose x) ts
 
 passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
 passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'

src/Dodge/Tree/Compose/Data.hs

@@ -12,4 +12,11 @@ data ComposingNode a
     | UseLabel  {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
 type SubCompTree a = Tree (ComposingNode a)
 type CompTree a = Tree (SubCompTree a)
+type LabSubCompTree a = (Tree (ComposingNode a),TreeSubLabelling)
+type LabCompTree a = Tree (LabSubCompTree a)
+data TreeSubLabelling = TreeSubLabelling
+    { _topLabel :: String
+    , _subLabels :: Maybe (Tree TreeSubLabelling)
+    }
 makeLenses ''ComposingNode
+makeLenses ''TreeSubLabelling