Dump some info to sdout when generating level

src/Dodge/Floor.hs

@@ -3,6 +3,7 @@
 The tree of rooms that make up a level. -}
 module Dodge.Floor
     ( levx
+    , layoutLevel
     ) where
 import Geometry.Data
 import Dodge.Data
@@ -23,17 +24,19 @@ import Dodge.Creature
 import Dodge.LevelGen.Data
 import Dodge.Item.Weapon.Launcher
 import MonadHelp
+import Data.Tree
 
 import Control.Lens
 import Control.Monad.State
 import Control.Monad.Loops
 import System.Random
-{- | A test level tree. -}
-initialRoomTree :: RandomGen g => State g (Maybe [Room])
-initialRoomTree = do
+import Data.Sequence hiding (zipWith)
+import Data.Maybe
+initialAnoTree :: RandomGen g => Tree [Annotation g]
+initialAnoTree =
     let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom]
-    let t' = padCorridors struct
-        t = treeFromTrunk 
+        t' = padWithCorridors struct
+    in treeFromTrunk 
             [[StartRoom]
             ,[SpecificRoom spawnerRoom]
             ,[Corridor]
@@ -95,9 +98,30 @@ initialRoomTree = do
             ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
             ] 
             t'
-    shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t
+
+{- | A test level tree. -}
+initialRoomTree :: RandomGen g => State g (Tree Room)
+initialRoomTree = do
+    expandTreeBy id <$> mapM annoToRoomTree initialAnoTree
 
 levx :: RandomGen g => Int -> State g ([Room] , Int)
-levx _ = untilJustCount initialRoomTree
+levx _ = untilJustCount $ shiftExpandTree <$> initialRoomTree
 
-        
+layoutLevel :: Int -> IO [Room]
+layoutLevel seed = do
+    putStrLn $ "Generating level with seed: " ++ show seed
+    let g = mkStdGen seed
+    let rmtree = evalState initialRoomTree g
+    mrs <- shiftRoomSearchIO [] (singleton rmtree)
+    case mrs of
+        Just rs -> return (fmap setLastLinkToUsed rs)
+        Nothing -> do
+            putStrLn "Level generation failed"
+            let (seed',_) = random g
+            layoutLevel seed'
+  where
+    setLastLinkToUsed rm = case _rmLinks rm of
+        (_:_) -> rm
+            & rmLinks %~ init
+            & rmUsedLinks %~ (last (_rmLinks rm) :)
+        _ -> rm