Improve diagnostics for level generation

src/Dodge/Floor.hs

@@ -2,8 +2,7 @@
 {- |
 The tree of rooms that make up a level. -}
 module Dodge.Floor
-    ( levx
-    , layoutLevel
+    ( layoutLevelFromSeed
     ) where
 import Geometry.Data
 import Dodge.Data
@@ -104,21 +103,18 @@ initialRoomTree :: RandomGen g => State g (Tree Room)
 initialRoomTree = do
     expandTreeBy id <$> mapM annoToRoomTree initialAnoTree
 
-levx :: RandomGen g => Int -> State g ([Room] , Int)
-levx _ = untilJustCount $ shiftExpandTree <$> initialRoomTree
-
-layoutLevel :: Int -> IO [Room]
-layoutLevel seed = do
+layoutLevelFromSeed :: Int -> IO [Room]
+layoutLevelFromSeed seed = do
     putStrLn $ "Generating level with seed: " ++ show seed
     let g = mkStdGen seed
     let rmtree = evalState initialRoomTree g
-    mrs <- shiftRoomSearchIO [] (singleton rmtree)
+    mrs <- positionRooms rmtree
     case mrs of
         Just rs -> return (fmap setLastLinkToUsed rs)
         Nothing -> do
             putStrLn "Level generation failed"
             let (seed',_) = random g
-            layoutLevel seed'
+            layoutLevelFromSeed seed'
   where
     setLastLinkToUsed rm = case _rmLinks rm of
         (_:_) -> rm

src/Dodge/Initialisation.hs

@@ -11,14 +11,11 @@ import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 import Geometry.Data
-import Dodge.Room.Data
 
 import System.Random
-import System.Timeout
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
-import Control.Monad.State
 
 firstWorld :: IO World
 firstWorld = do
@@ -28,18 +25,9 @@ firstWorld = do
 --    let g = mkStdGen i
 --    (roomList,n) <- f g
 --    putStrLn $ "Had to go through "++ show n ++ " random generators"
-    roomList <- layoutLevel i
-    return $ generateLevelFromRoomList roomList $ initialWorld -- note this uses a random generator defined elsewhere
-  where
-    f :: StdGen -> IO ([Room],Int)
-    f g = do
-        mayrs <- timeout 10000000 . return $ evalState (levx 1) g
-        case mayrs of
-            Nothing -> do
-                let i = fst $ random g
-                putStrLn $ "Timeout; trying new seed: " ++ show i
-                f (mkStdGen i)
-            Just rs -> return rs
+    roomList <- layoutLevelFromSeed i
+    return $ generateLevelFromRoomList roomList 
+        $ initialWorld -- note this uses a random generator defined elsewhere
 
 initialWorld :: World
 initialWorld = defaultWorld

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -14,6 +14,7 @@ module Dodge.Layout.Tree.Polymorphic
     , splitTrunk
     , applyToRandomNode
     , addToTrunk
+    , bfnumberTree
     )
     where
 import Dodge.RandomHelp
@@ -142,3 +143,16 @@ splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a])
 splitTrunk t = do
     i <- state $ randomR (0, trunkDepth t)
     return $ splitTrunkAt i t
+
+-- untested
+bfnumberTree :: Tree a -> Tree (a,Int)
+bfnumberTree = fst . f 0
+  where
+    f i (Node x ts) =
+        let (ts',i') = g (i+1) ts
+        in (Node (x,i) ts', i')
+    g i (t:ts) = 
+        let (t',i') = f i t
+            (ts',i'') = g i' ts
+        in ((t': ts'), i'')
+    g i [] = ([], i)

src/Dodge/Layout/Tree/Shift.hs

@@ -6,7 +6,7 @@ Returns a list; after this step the structure is determined by the actual positi
 module Dodge.Layout.Tree.Shift
     ( shiftRoomTreeSearchAll
     , shiftExpandTree
-    , shiftRoomSearchIO
+    , positionRooms
     ) where
 import Dodge.Room.Data
 import Dodge.Room.Link
@@ -18,6 +18,7 @@ import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
 import Data.Maybe (listToMaybe)
+import Data.Bifunctor
 import Control.Lens hiding (Empty, (<|) , (|>))
 
 {- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.  -}
@@ -43,37 +44,77 @@ shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
     useLink l = r & rmLinks %~ delete l
         & rmUsedLinks %~ (l :)
     f l = applyToRoot (shiftRoomToLink l)
-shiftRoomSearchIO
+
+positionRooms :: Tree Room -> IO (Maybe [Room])
+--positionRooms = shiftRoomSearchIO 0 [] . singleton
+positionRooms t =
+    let (Node (r,i) ts) = bfnumberTree t
+    in posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
+
+type RoomInt = (Room,Int)
+
+posRms
     :: [ConvexPoly]
+    -> RoomInt
+    -> [Tree RoomInt]
+    -> Seq (Tree RoomInt)
+    -> IO (Maybe [Room])
+posRms _ _ [] Empty = return $ Just []
+posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) = fmap (fmap (rtoadd:)) $ posRms bounds (r,i) ts tseq
+posRms bounds (r,i) (t:ts) tseq = tryLinks' (_rmLinks r)
+  where
+    tryLinks' [] = do
+        putStrLn "All links tried"
+        return Nothing
+    tryLinks' (l:ls) 
+        | clipping   = tryLinks' ls
+        | otherwise = do
+            putStrLn $ "Trying link from " ++ show i ++ " to " ++ show i'
+            mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt)
+            case mayrs of
+                Nothing -> do putStrLn ("Backtracking to " ++ show i) >> tryLinks' ls
+                Just rs -> return (Just rs)
+      where
+        convexBounds = map pointsToPoly $ _rmBound r'
+        clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
+        useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (l :)
+            , i)
+        shiftedt@(Node (r',i') _) = applyToRoot (first $ shiftRoomToLink l) t
+        
+
+shiftRoomSearchIO
+    :: Int
+    -> [ConvexPoly]
     -> Seq (Tree Room)
     -> IO (Maybe [Room])
-shiftRoomSearchIO _ Empty = return (Just [])
-shiftRoomSearchIO bs (Node r ts :<| tseq) 
+shiftRoomSearchIO _ _ Empty = return (Just [])
+shiftRoomSearchIO i bs (Node r ts :<| tseq) 
     | roomIsClipping = do
-        putStrLn "Room clipping"
+        putStrLn $ "Room " ++ show i ++ " clipping"
         return Nothing
-    | otherwise      = fmap (fmap (r:)) $ placeLinkedRooms newBounds r ts tseq
+    | otherwise      = fmap (fmap (r:)) $ placeLinkedRooms i newBounds r ts tseq
   where
     convexBounds = map pointsToPoly $ _rmBound r
     newBounds = convexBounds ++ bs
     roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
-placeLinkedRooms :: [ConvexPoly] -> Room -> [Tree Room] -> (Seq (Tree Room)) -> IO (Maybe [Room])
-placeLinkedRooms bs _ [] tseq
-    = shiftRoomSearchIO bs tseq
-placeLinkedRooms bs r (t:ts) tseq
-    = tryLinks ls bs r t ts tseq
+placeLinkedRooms :: Int -> [ConvexPoly] -> Room -> [Tree Room] -> (Seq (Tree Room)) -> IO (Maybe [Room])
+placeLinkedRooms i bs _ [] tseq
+    = shiftRoomSearchIO (i+1) bs tseq
+placeLinkedRooms i bs r (t:ts) tseq
+    = tryLinks i ls bs r t ts tseq
   where
     ls = init $ _rmLinks r
 
-tryLinks :: [(Point2,Float)] -> [ConvexPoly] -> Room -> Tree Room -> [Tree Room] -> (Seq (Tree Room))
+tryLinks :: Int 
+    -> [(Point2,Float)] -> [ConvexPoly] -> Room -> Tree Room -> [Tree Room] -> (Seq (Tree Room))
     -> IO (Maybe [Room])
-tryLinks [] _ _ _ _ _ = do
-    putStrLn "Tried all links"
+tryLinks i [] _ _ _ _ _ = do
+    putStrLn $ "Tried all links for room " ++ show i
     return Nothing
-tryLinks (l:ls) bs r t ts tseq = do
-    branch <- placeLinkedRooms bs useLink ts (tseq |> shiftedt)
+tryLinks i (l:ls) bs r t ts tseq = do
+    branch <- placeLinkedRooms i bs useLink ts (tseq |> shiftedt)
     case branch of
-        Nothing -> tryLinks ls bs r t ts tseq
+        Nothing -> tryLinks i ls bs r t ts tseq
         Just rs -> return $ Just rs
   where
     useLink = r & rmLinks %~ delete l