Allow for random choice between placements in different rooms

src/Dodge/LevelGen.hs

@@ -8,10 +8,14 @@ import Dodge.Floor
 import Dodge.Layout
 import Dodge.Initialisation
 import Dodge.RandomHelp
+import Dodge.LevelGen.Data
+import Dodge.Tree
 
+import Data.Tree
 import System.Random
 import Control.Lens
 import Control.Monad.State
+import qualified Data.IntMap.Strict as IM
 
 generateWorldFromSeed :: Int -> IO World
 generateWorldFromSeed i = do
@@ -21,3 +25,42 @@ generateWorldFromSeed i = do
 
 randomCompass :: World -> World
 randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
+
+layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room)
+layoutLevelFromSeed i seed = do
+    let i' = i + 1
+    putStrLn $ "Generating level with seed " ++ show seed
+    let g = mkStdGen seed
+    let rmtree = inorderNumberTree $ evalState initialRoomTree g
+    putStrLn "Abstract layout: "
+    putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
+    mrs <- positionRoomsFromTree rmtree
+    case mrs of
+        Just rs -> do
+            putStrLn $ "After " ++ show i' 
+                ++ " attempt(s), Successful generation of level with seed " 
+                ++ show seed
+            --return (fmap setLastLinkToUsed rs)
+            putStrLn $ show (Prelude.length rs) ++ " rooms in total"
+            return . IM.fromList $ map reversePair rs
+        Nothing -> do
+            putStr $ "Level generation with seed " ++ show seed ++ " failed: "
+            let (seed',_) = random g
+            layoutLevelFromSeed i' seed'
+
+reversePair :: (a,b) -> (b,a)
+reversePair (a,b) = (b,a)
+
+compactDrawTree :: Tree String -> String
+compactDrawTree = unlines . compactDraw
+
+compactDraw :: Tree String -> [String]
+compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
+compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
+  where
+    drawSubTrees [] = []
+    drawSubTrees [t] =
+        "|" : compactDraw t
+    drawSubTrees (t:ts) =
+        "|" : shift "+- " "|  " (compactDraw t) ++ drawSubTrees ts
+    shift first other = zipWith (++) (first : repeat other)