Display abstract tree of placement, stout

src/Dodge/Floor.hs

@@ -105,14 +105,18 @@ initialRoomTree = do
 
 layoutLevelFromSeed :: Int -> IO [Room]
 layoutLevelFromSeed seed = do
-    putStrLn $ "Generating level with seed: " ++ show seed
+    putStrLn $ "Generating level with seed " ++ show seed
     let g = mkStdGen seed
-    let rmtree = evalState initialRoomTree g
+    let rmtree = inorderNumberTree $ evalState initialRoomTree g
+    putStrLn "Seed layout: "
+    putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
     mrs <- positionRooms rmtree
     case mrs of
-        Just rs -> return (fmap setLastLinkToUsed rs)
+        Just rs -> do
+            putStrLn $ "Successful generation of level with seed " ++ show seed
+            return (fmap setLastLinkToUsed rs)
         Nothing -> do
-            putStrLn "Level generation failed"
+            putStr $ "Level generation with seed " ++ show seed ++ " failed: "
             let (seed',_) = random g
             layoutLevelFromSeed seed'
   where
@@ -121,3 +125,18 @@ layoutLevelFromSeed seed = do
             & rmLinks %~ init
             & rmUsedLinks %~ (last (_rmLinks rm) :)
         _ -> rm
+
+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)

src/Dodge/Initialisation.hs

@@ -27,7 +27,7 @@ firstWorld = do
 --    putStrLn $ "Had to go through "++ show n ++ " random generators"
     roomList <- layoutLevelFromSeed i
     return $ generateLevelFromRoomList roomList 
-        $ initialWorld -- note this uses a random generator defined elsewhere
+         initialWorld -- note this uses a random generator defined elsewhere
 
 initialWorld :: World
 initialWorld = defaultWorld

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -14,7 +14,7 @@ module Dodge.Layout.Tree.Polymorphic
     , splitTrunk
     , applyToRandomNode
     , addToTrunk
-    , bfnumberTree
+    , inorderNumberTree
     )
     where
 import Dodge.RandomHelp
@@ -145,8 +145,8 @@ splitTrunk t = do
     return $ splitTrunkAt i t
 
 -- untested
-bfnumberTree :: Tree a -> Tree (a,Int)
-bfnumberTree = fst . f 0
+inorderNumberTree :: Tree a -> Tree (a,Int)
+inorderNumberTree = fst . f 0
   where
     f i (Node x ts) =
         let (ts',i') = g (i+1) ts
@@ -154,5 +154,5 @@ bfnumberTree = fst . f 0
     g i (t:ts) = 
         let (t',i') = f i t
             (ts',i'') = g i' ts
-        in ((t': ts'), i'')
+        in (t': ts', i'')
     g i [] = ([], i)

src/Dodge/Layout/Tree/Shift.hs

@@ -5,19 +5,17 @@ Returns a list; after this step the structure is determined by the actual positi
  -}
 module Dodge.Layout.Tree.Shift
     ( shiftRoomTreeSearchAll
-    , shiftExpandTree
     , positionRooms
     ) where
 import Dodge.Room.Data
 import Dodge.Room.Link
 import Dodge.Layout.Tree.Polymorphic
 import Geometry.ConvexPoly
-import Geometry
 
 import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
-import Data.Maybe (listToMaybe)
+--import Data.Maybe (listToMaybe)
 import Data.Bifunctor
 import Control.Lens hiding (Empty, (<|) , (|>))
 
@@ -45,11 +43,8 @@ shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
         & rmUsedLinks %~ (l :)
     f l = applyToRoot (shiftRoomToLink l)
 
-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
+positionRooms :: Tree RoomInt -> IO (Maybe [Room])
+positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
 
 type RoomInt = (Room,Int)
 
@@ -60,75 +55,33 @@ posRms
     -> 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)
+posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) = fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq
+posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
+    putStr $ "Trying to place room " ++ show i' ++ ": "
+    tryLinks' (0::Int) (_rmLinks r)
   where
-    tryLinks' [] = do
-        putStrLn "All links tried"
+    tryLinks' _ [] = do
+        putStrLn "all links tried"
         return Nothing
-    tryLinks' (l:ls) 
-        | clipping   = tryLinks' ls
+    tryLinks' j (l:ls) 
+        | clipping   = tryLinks' (j+1) ls
         | otherwise = do
-            putStrLn $ "Trying link from " ++ show i ++ " to " ++ show i'
+            putStrLn $ "placing at link " ++ show j
             mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt)
             case mayrs of
-                Nothing -> do putStrLn ("Backtracking to " ++ show i) >> tryLinks' ls
+                Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks' (j+1) 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
+        shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
         
 
-shiftRoomSearchIO
-    :: Int
-    -> [ConvexPoly]
-    -> Seq (Tree Room)
-    -> IO (Maybe [Room])
-shiftRoomSearchIO _ _ Empty = return (Just [])
-shiftRoomSearchIO i bs (Node r ts :<| tseq) 
-    | roomIsClipping = do
-        putStrLn $ "Room " ++ show i ++ " clipping"
-        return Nothing
-    | 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 :: 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 :: Int 
-    -> [(Point2,Float)] -> [ConvexPoly] -> Room -> Tree Room -> [Tree Room] -> (Seq (Tree Room))
-    -> IO (Maybe [Room])
-tryLinks i [] _ _ _ _ _ = do
-    putStrLn $ "Tried all links for room " ++ show i
-    return Nothing
-tryLinks i (l:ls) bs r t ts tseq = do
-    branch <- placeLinkedRooms i bs useLink ts (tseq |> shiftedt)
-    case branch of
-        Nothing -> tryLinks i ls bs r t ts tseq
-        Just rs -> return $ Just rs
-  where
-    useLink = r & rmLinks %~ delete l
-        & rmUsedLinks %~ (l :)
-    shiftedt = applyToRoot (shiftRoomToLink l) t
-
-{- |
-Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
- -}
-shiftExpandTree :: Tree Room -> Maybe [Room]
-shiftExpandTree = fmap (map setLastLinkToUsed) . listToMaybe . shiftRoomTreeSearchAll [] . singleton
-  where
-    setLastLinkToUsed rm = case _rmLinks rm of
-        (_:_) -> rm
-            & rmLinks %~ init
-            & rmUsedLinks %~ (last (_rmLinks rm) :)
-        _ -> rm
+setLastLinkToUsed :: Room -> Room
+setLastLinkToUsed rm = case _rmLinks rm of
+    (_:_) -> rm
+        & rmLinks %~ init
+        & rmUsedLinks %~ (last (_rmLinks rm) :)
+    _ -> rm