Commit before improving logging of annotations

src/Dodge/Annotation.hs

@@ -13,7 +13,7 @@ import Dodge.Annotation.Data
 import LensHelp
 
 --import Control.Lens
---import Data.Maybe
+import Data.Maybe
 
 {- | Add one corridor between each parent-child link of a tree of annotations.  -}
 --padWithCorridors :: Annotation -> Annotation
@@ -48,11 +48,19 @@ annoToRoomTree' an = case an of
     OnwardList ans -> do
         mts <- mapM annoToRoomTree' ans
         return $ foldr1 attachOnward mts
-    IntAnno' f -> do 
+    IntAnno f -> do 
         (g,i) <- get
         put (g,i+1)
         annoToRoomTree' (f i)
     PadWith r an -> annoToRoomTree' an
+    PassthroughLockKeyLists ls ks i -> zoom _1 $ do
+        (functionlockroom,randomitemidentity) <- takeOne ls
+        lr <- functionlockroom i
+        ii <- randomitemidentity
+        keyroom <- fromJust $ lookup ii ks
+        return $ MTree ("PassthroughLockKeyLists-"++show ii) 
+            (MTree "" lr [MBranch "" (toLabel' i) keyroom])
+            []
 
 --annoToRoomTree :: Annotation -> State StdGen (MetaTree Room)
 --annoToRoomTree an = case an of

src/Dodge/Annotation/Data.hs

@@ -15,12 +15,13 @@ data Annotation
     PadWith Room Annotation
     | OnwardList [Annotation]
 --    | IntAnno Int (Int -> Annotation)
-    | IntAnno' (Int -> Annotation)
+    | IntAnno (Int -> Annotation)
 --    | OrAno [[Annotation]]
     | SpecificRoom (State StdGen (MetaTree Room))
     | AnoApplyInt Int (Int -> State StdGen (LabTree Room))
-    | PassthroughLockKeyLists Int 
-        [(Int -> State StdGen (LabTree Room), State StdGen ItemBaseType)]
-        [(ItemBaseType, State StdGen (LabTree Room))]
+    | PassthroughLockKeyLists
+        [(Int -> State StdGen (MetaTree Room), State StdGen ItemBaseType)]
+        [(ItemBaseType, State StdGen (MetaTree Room))]
+         Int 
 
 makeLenses ''Annotation

src/Dodge/Floor.hs

@@ -31,27 +31,31 @@ import RandomHelp
 --import Color
 --import Dodge.Wire
 
+import Data.List (intersperse)
 --import Data.Sequence hiding (zipWith)
 --import Data.Maybe
 --import qualified Data.IntMap.Strict as IM
 
 initialAnoTree :: Annotation
 initialAnoTree = PadWith door $ OnwardList 
-    [ IntAnno' $ SpecificRoom . startRoom
---    , PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms
-    , IntAnno' $ SpecificRoom . warningRooms
+        $ intersperse 
+        (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
+    [ IntAnno $ SpecificRoom . startRoom
+     ,  (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
+    , IntAnno $ PassthroughLockKeyLists
+        [(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms
+    , IntAnno $ PassthroughLockKeyLists keyCardRunPastRand itemRooms
+    , IntAnno $ SpecificRoom . warningRooms
     , SpecificRoom $ rToOnward "chaseCrit+armourChaseCrit rectRoom"
         $ return . cleatOnward $ roomRectAutoLinks 400 400 & rmPmnts .++~ 
             [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
             , spNoID anyUnusedSpot (PutCrit armourChaseCrit)
             ]
---"--    , [AnoApplyInt 100 healthTest]
---"    , PassthroughLockKeyLists 23 
---"        [(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms
---"    , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
---"    , PassthroughLockKeyLists 222 lockRoomKeyItems itemRooms
+--a--    , [AnoApplyInt 100 healthTest]
+--a    , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
+--"    , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms
 --"    , SpecificRoom randomChallenges
---"    , AnoApplyInt 1 lasSensorTurretTest
+--"    , IntAnno $ SpecificRoom . lasSensorTurretTest
 --"--    ,[SpecificRoom $ fmap pure roomCCrits]
 --"--    ,[AirlockAno]
 --"--    ,[Corridor]

src/Dodge/Room/SensorDoor.hs

@@ -63,7 +63,7 @@ sensorRoomRunPast dt n = do
         (++
             [treePost 
                 [ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s))
-                , cleatLabel 0 corridor ]
+                , cleatLabel n corridor ]
             ]
         ) 
 

src/Dodge/Tree/Compose.hs

@@ -16,7 +16,7 @@ module Dodge.Tree.Compose
     , attachTree
     , composeTreeRand
     , composeAndLog
-    , cmpToMT
+--    , cmpToMT
 --    , compTree
     ) where
 import Dodge.Data

src/Dodge/UseAll.hs

@@ -16,6 +16,11 @@ toOnward s rm
 toOnward' :: Room -> Maybe Room
 toOnward' = fmap snd . toOnward ""
 
+toLabel' :: Int -> Room -> Maybe Room
+toLabel' i rm
+    | LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just rm
+    | otherwise = Nothing
+
 rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room)
 rToOnward s t = return $ MTree s (tToBTree t) []