From da22d9833ad8fe4342fccee363ee7c62cd004011 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 11 Nov 2021 17:08:03 +0000 Subject: [PATCH] Improve diagnostics for level generation --- src/Dodge/Floor.hs | 14 ++---- src/Dodge/Initialisation.hs | 18 ++----- src/Dodge/Layout/Tree/Polymorphic.hs | 14 ++++++ src/Dodge/Layout/Tree/Shift.hs | 75 +++++++++++++++++++++------- 4 files changed, 80 insertions(+), 41 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index f01efeeb7..89f271db4 100644 --- a/src/Dodge/Floor.hs +++ b/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 diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 08bd9dc82..705681b36 100644 --- a/src/Dodge/Initialisation.hs +++ b/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 diff --git a/src/Dodge/Layout/Tree/Polymorphic.hs b/src/Dodge/Layout/Tree/Polymorphic.hs index cc885107f..1510e619f 100644 --- a/src/Dodge/Layout/Tree/Polymorphic.hs +++ b/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) diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index dd1794979..d9dc385cb 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/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