From 8c45a02e462f479364c85323e60871495b4bb0ba Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 11 Nov 2021 18:41:59 +0000 Subject: [PATCH] Display abstract tree of placement, stout --- src/Dodge/Floor.hs | 27 +++++++-- src/Dodge/Initialisation.hs | 2 +- src/Dodge/Layout/Tree/Polymorphic.hs | 8 +-- src/Dodge/Layout/Tree/Shift.hs | 87 +++++++--------------------- 4 files changed, 48 insertions(+), 76 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 89f271db4..5c86da9f8 100644 --- a/src/Dodge/Floor.hs +++ b/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) diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 705681b36..e002050e8 100644 --- a/src/Dodge/Initialisation.hs +++ b/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 diff --git a/src/Dodge/Layout/Tree/Polymorphic.hs b/src/Dodge/Layout/Tree/Polymorphic.hs index 1510e619f..f3eaecbfe 100644 --- a/src/Dodge/Layout/Tree/Polymorphic.hs +++ b/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) diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index d9dc385cb..229939265 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/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