Move towards better annotations when generating layouts

src/Dodge/Annotation.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {- | Annotating tree structures with desired properties for rooms.  -}
 module Dodge.Annotation 
     ( module Dodge.Annotation.Data
@@ -7,6 +8,7 @@ import Dodge.RandomHelp
 import Dodge.Tree
 import Dodge.Room
 import Dodge.Annotation.Data
+import LensHelp
 
 import Data.Tree
 import Control.Monad.State
@@ -52,11 +54,18 @@ roomThenCorridor theRoom = fmap
     (shuffleLinks corridor)
 
 {- | Create a random room tree structure from a list of annotations.  -}
-anoToRoomTree :: [Annotation] -> State StdGen (SubCompTree Room)
+anoToRoomTree :: [Annotation] -> State StdGen (SubCompTree Room,String)
 anoToRoomTree anos = case anos of
     [AnoApplyInt i f] -> f i
+    [AnoApplyInt' i f str] -> f i <&> (,str)
+    _ -> fmap (,"") $ 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
+        rms <- mapM anoToRoomTree' ass
         return $ chainUses rms
     [PassthroughLockKeyLists i ls ks] -> do
         (functionlockroom,randomitemidentity) <- takeOne ls
@@ -66,7 +75,7 @@ anoToRoomTree anos = case anos of
         return $ overwriteLabel 0 UseNone lr [keyroom]
     [OrAno as] -> do
         a <- takeOne as
-        anoToRoomTree a
+        anoToRoomTree' a
     [Corridor] -> pure . UseAll <$> shuffleLinks corridor
     (SpecificRoom rt:_) -> rt
     (BossAno cr : _) -> do

src/Dodge/Annotation/Data.hs

@@ -17,7 +17,8 @@ data Annotation
     | SpecificRoom (State StdGen (SubCompTree Room))
     | BossAno Creature
     | TreasureAno [Creature] [Item]
-    | AnoApplyInt Int (Int -> State StdGen (SubCompTree Room))
+    | AnoApplyInt Int (Int -> State StdGen (SubCompTree Room,String))
+    | AnoApplyInt' Int (Int -> State StdGen (SubCompTree Room)) String
     | AnoNewInt (Int -> State StdGen (SubCompTree Room))
     | PassthroughLockKeyLists Int 
         [(Int -> State StdGen (SubCompTree Room), State StdGen CombineType)]

src/Dodge/Floor.hs

@@ -47,7 +47,7 @@ initialAnoTree = padSucWithDoors $ treeFromTrunk
     , [SpecificRoom $ return . UseAll <$> tanksRoom [] []]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
     , [SpecificRoom randomChallenges]
-    , [AnoApplyInt 1 lasSensorTurretTest]
+    , [AnoApplyInt' 1 lasSensorTurretTest "lasSensorTurretTest"]
 --    ,[SpecificRoom $ fmap singleUseAll roomCCrits]
 --    ,[AirlockAno]
 --    ,[Corridor]
@@ -92,6 +92,8 @@ initialAnoTree = padSucWithDoors $ treeFromTrunk
     [SpecificRoom $ fmap (pure . UseAll) (telRoomLev 1)]
 
 {- | A test level tree. -}
-initialRoomTree :: State StdGen (Tree Room)
+initialRoomTree :: State StdGen (Tree (SubCompTree Room,String))
-initialRoomTree = do
+initialRoomTree = mapM anoToRoomTree initialAnoTree
-    expandTree <$> mapM anoToRoomTree initialAnoTree
+--initialRoomTree :: State StdGen (Tree Room)
+--initialRoomTree = do
+--    expandTree <$> mapM anoToRoomTree initialAnoTree

src/Dodge/LevelGen.hs

@@ -20,6 +20,7 @@ import qualified Data.IntMap.Strict as IM
 
 generateWorldFromSeed :: Int -> IO World
 generateWorldFromSeed i = do
+    writeFile "attemptedSeeds" ""
     (roomList,bounds) <- layoutLevelFromSeed 0 i
     return $ saveLevelStartSlot $ _gWorld (generateLevelFromRoomList roomList 
          initialWorld{_randGen=mkStdGen i})
@@ -29,12 +30,16 @@ layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly])
 layoutLevelFromSeed i seed = do
     let i' = i + 1
     putStrLn $ "Generating level with seed " ++ show seed
+    appendFile "attemptedSeeds" $ show seed ++ "\n"
     let g = mkStdGen seed
-    let rmtree = inorderNumberTree $ evalState initialRoomTree g
+    let treecluster = evalState initialRoomTree g
-    putStrLn "Compact layout: "
+    putStrLn "Room cluster layout:"
+    putStrLn $ drawTree $ fmap snd treecluster
+    let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
+    putStrLn "Room layout (compact): "
     putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
     let nameshow (r,rid) = _rmName r ++ "-" ++ show rid
-    writeFile "aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree
+    appendFile "aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree
     putStrLn "Layout with room names (also written to aGeneratedRoomLayout):"
     mrs <- positionRoomsFromTree rmtree
     case mrs of

src/Dodge/Room/Room.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Room where
 import Data.Tile
 import Dodge.Data
@@ -200,7 +201,7 @@ weaponUnderCrits i = do
     let plmnts = 
             [--sPS (V2 20 0)   0 $ RandPS randFirstWeapon
             sPS (V2 20 0)  (negate $ pi/2) randC1
-            ,sPS (V2 20 20) (negate $ pi/2) randC1
+            ,sPS (V2 20 20) ( pi/2) randC1
             ]
         addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon)
     let continuationRoom = treeFromTrunk 
@@ -288,13 +289,13 @@ deadEndRoom = defaultRoom
   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)
+weaponRoom :: RandomGen g => Int -> State g (SubCompTree Room, String)
 weaponRoom i = join $ takeOne 
-    [ weaponEmptyRoom
+    [ weaponEmptyRoom      <&> (, "weaponEmptyRoom")
-    , weaponUnderCrits i
+    , weaponUnderCrits i<&> (, "weaponUnderCrits")
-    , weaponBehindPillar
+    , weaponBehindPillar<&> (, "weaponBehindPillar")
-    , weaponBetweenPillars
+    , weaponBetweenPillars<&> (, "weaponBetweenPillars")
-    , weaponLongCorridor
+    , weaponLongCorridor<&> (, "weaponLongCorridor")
     ]
 
 roomCCrits :: RandomGen g => State g Room

src/Dodge/Room/Start.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Start where
 import Dodge.Data
 import Dodge.LevelGen.Data
@@ -48,14 +49,16 @@ powerFakeout = do
                 ,PassDown keyholeCorridor,PassDown corridor])
         `treeFromPost` UseAll door
 
-startRoom :: RandomGen g => Int -> State g (SubCompTree Room)
+startRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
 startRoom i = join $ uncurry takeOneWeighted $ unzip 
-    [ (,) (0.5::Float) $ chainUses <$> sequence [powerFakeout,weaponRoom i]
+    [ (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) 
-    , (,) one rezBoxesWp
+            <&> (,"chainUses <$> sequence [powerFakeout,weaponRoom i]"))
+    , (,) one (rezBoxesWp <&> (, "rezBoxesWp"))
     , (,) one (rezBoxThenWeaponRoom i)
-    , (,) one rezBoxesWpCrit
+    , (,) one (rezBoxesWpCrit <&> (,"rezBoxesWpCrit"))
-    , (,) 1 $ runPastStart i
+    , (,) one (runPastStart i <&> (,"runPastStart " ++ show i))
-    , (,) 1 $ startCrafts >>= roomsContaining [] >>= rezBoxThenRooms
+    , (,) one (startCrafts >>= roomsContaining [] >>= rezBoxThenRooms <&> 
+        (,"startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"))
     ]
   where
     one = 1::Float
@@ -77,16 +80,18 @@ rezBoxStart = do
     ls <- rezColor
     return $ treeFromPost [PassDown $ rezBox ls] (UseAll door)
 
-rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room)
+rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
 rezBoxesThenWeaponRoom i = do
     rboxes <- rezBoxes
-    wroom  <- weaponRoom i
+    wroom  <- fmap fst $ weaponRoom i
-    return $ rboxes `passUntilUseAll` [wroom]
+    return (rboxes `passUntilUseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
 
-rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room)
+rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
 rezBoxThenWeaponRoom i = do
     rcol <- rezColor
-    treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom i
+    (wroom,wroomname) <- weaponRoom i
+    return $ (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom
+         , "rezBoxThenWeaponRoom "++ show i ++ ":" ++ wroomname)
 
 rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room)
 rezBoxThenRoom r = do