From 1739d648fe5ea3d25f01281778c063831d2c4ab4 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 20 May 2022 11:14:11 +0100 Subject: [PATCH] Move towards better annotations when generating layouts --- src/Dodge/Annotation.hs | 15 ++++++++++++--- src/Dodge/Annotation/Data.hs | 3 ++- src/Dodge/Floor.hs | 10 ++++++---- src/Dodge/LevelGen.hs | 11 ++++++++--- src/Dodge/Room/Room.hs | 15 ++++++++------- src/Dodge/Room/Start.hs | 27 ++++++++++++++++----------- 6 files changed, 52 insertions(+), 29 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 16f213396..e55cdb7e6 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {- | Annotating tree structures with desired properties for rooms. -} module Dodge.Annotation ( module Dodge.Annotation.Data @@ -7,6 +8,7 @@ import Dodge.RandomHelp import Dodge.Tree import Dodge.Room import Dodge.Annotation.Data +import LensHelp import Data.Tree import Control.Monad.State @@ -52,11 +54,18 @@ roomThenCorridor theRoom = fmap (shuffleLinks corridor) {- | Create a random room tree structure from a list of annotations. -} -anoToRoomTree :: [Annotation] -> State StdGen (SubCompTree Room) +anoToRoomTree :: [Annotation] -> State StdGen (SubCompTree Room,String) anoToRoomTree anos = case anos of [AnoApplyInt i f] -> f i + [AnoApplyInt' i f str] -> f i <&> (,str) + _ -> fmap (,"") $ anoToRoomTree' anos + +{- | Create a random room tree structure from a list of annotations. -} +anoToRoomTree' :: [Annotation] -> State StdGen (SubCompTree Room) +anoToRoomTree' anos = case anos of +-- [AnoApplyInt i f] -> f i [ChainAnos ass] -> do - rms <- mapM anoToRoomTree ass + rms <- mapM anoToRoomTree' ass return $ chainUses rms [PassthroughLockKeyLists i ls ks] -> do (functionlockroom,randomitemidentity) <- takeOne ls @@ -66,7 +75,7 @@ anoToRoomTree anos = case anos of return $ overwriteLabel 0 UseNone lr [keyroom] [OrAno as] -> do a <- takeOne as - anoToRoomTree a + anoToRoomTree' a [Corridor] -> pure . UseAll <$> shuffleLinks corridor (SpecificRoom rt:_) -> rt (BossAno cr : _) -> do diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index 6006cd309..24aecfcf4 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -17,7 +17,8 @@ data Annotation | SpecificRoom (State StdGen (SubCompTree Room)) | BossAno Creature | TreasureAno [Creature] [Item] - | AnoApplyInt Int (Int -> State StdGen (SubCompTree Room)) + | AnoApplyInt Int (Int -> State StdGen (SubCompTree Room,String)) + | AnoApplyInt' Int (Int -> State StdGen (SubCompTree Room)) String | AnoNewInt (Int -> State StdGen (SubCompTree Room)) | PassthroughLockKeyLists Int [(Int -> State StdGen (SubCompTree Room), State StdGen CombineType)] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 460fd3812..4a76e443d 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -47,7 +47,7 @@ initialAnoTree = padSucWithDoors $ treeFromTrunk , [SpecificRoom $ return . UseAll <$> tanksRoom [] []] , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms] , [SpecificRoom randomChallenges] - , [AnoApplyInt 1 lasSensorTurretTest] + , [AnoApplyInt' 1 lasSensorTurretTest "lasSensorTurretTest"] -- ,[SpecificRoom $ fmap singleUseAll roomCCrits] -- ,[AirlockAno] -- ,[Corridor] @@ -92,6 +92,8 @@ initialAnoTree = padSucWithDoors $ treeFromTrunk [SpecificRoom $ fmap (pure . UseAll) (telRoomLev 1)] {- | A test level tree. -} -initialRoomTree :: State StdGen (Tree Room) -initialRoomTree = do - expandTree <$> mapM anoToRoomTree initialAnoTree +initialRoomTree :: State StdGen (Tree (SubCompTree Room,String)) +initialRoomTree = mapM anoToRoomTree initialAnoTree +--initialRoomTree :: State StdGen (Tree Room) +--initialRoomTree = do +-- expandTree <$> mapM anoToRoomTree initialAnoTree diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index ce49c75e0..f1b998657 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -20,6 +20,7 @@ import qualified Data.IntMap.Strict as IM generateWorldFromSeed :: Int -> IO World generateWorldFromSeed i = do + writeFile "attemptedSeeds" "" (roomList,bounds) <- layoutLevelFromSeed 0 i return $ saveLevelStartSlot $ _gWorld (generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i}) @@ -29,12 +30,16 @@ layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly]) layoutLevelFromSeed i seed = do let i' = i + 1 putStrLn $ "Generating level with seed " ++ show seed + appendFile "attemptedSeeds" $ show seed ++ "\n" let g = mkStdGen seed - let rmtree = inorderNumberTree $ evalState initialRoomTree g - putStrLn "Compact layout: " + let treecluster = evalState initialRoomTree g + putStrLn "Room cluster layout:" + putStrLn $ drawTree $ fmap snd treecluster + let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster + putStrLn "Room layout (compact): " putStrLn $ compactDrawTree $ fmap (show . snd) rmtree let nameshow (r,rid) = _rmName r ++ "-" ++ show rid - writeFile "aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree + appendFile "aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree putStrLn "Layout with room names (also written to aGeneratedRoomLayout):" mrs <- positionRoomsFromTree rmtree case mrs of diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 4fe0168fb..0041c2673 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.Room where import Data.Tile import Dodge.Data @@ -200,7 +201,7 @@ weaponUnderCrits i = do let plmnts = [--sPS (V2 20 0) 0 $ RandPS randFirstWeapon sPS (V2 20 0) (negate $ pi/2) randC1 - ,sPS (V2 20 20) (negate $ pi/2) randC1 + ,sPS (V2 20 20) ( pi/2) randC1 ] addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon) let continuationRoom = treeFromTrunk @@ -288,13 +289,13 @@ deadEndRoom = defaultRoom where lnks = [(V2 0 30 ,0) ] {- A random Either tree with a weapon and melee monster challenge. -} -weaponRoom :: RandomGen g => Int -> State g (SubCompTree Room) +weaponRoom :: RandomGen g => Int -> State g (SubCompTree Room, String) weaponRoom i = join $ takeOne - [ weaponEmptyRoom - , weaponUnderCrits i - , weaponBehindPillar - , weaponBetweenPillars - , weaponLongCorridor + [ weaponEmptyRoom <&> (, "weaponEmptyRoom") + , weaponUnderCrits i<&> (, "weaponUnderCrits") + , weaponBehindPillar<&> (, "weaponBehindPillar") + , weaponBetweenPillars<&> (, "weaponBetweenPillars") + , weaponLongCorridor<&> (, "weaponLongCorridor") ] roomCCrits :: RandomGen g => State g Room diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 398982374..8ccb46d9b 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Room.Start where import Dodge.Data import Dodge.LevelGen.Data @@ -48,14 +49,16 @@ powerFakeout = do ,PassDown keyholeCorridor,PassDown corridor]) `treeFromPost` UseAll door -startRoom :: RandomGen g => Int -> State g (SubCompTree Room) +startRoom :: RandomGen g => Int -> State g (SubCompTree Room,String) startRoom i = join $ uncurry takeOneWeighted $ unzip - [ (,) (0.5::Float) $ chainUses <$> sequence [powerFakeout,weaponRoom i] - , (,) one rezBoxesWp + [ (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) + <&> (,"chainUses <$> sequence [powerFakeout,weaponRoom i]")) + , (,) one (rezBoxesWp <&> (, "rezBoxesWp")) , (,) one (rezBoxThenWeaponRoom i) - , (,) one rezBoxesWpCrit - , (,) 1 $ runPastStart i - , (,) 1 $ startCrafts >>= roomsContaining [] >>= rezBoxThenRooms + , (,) one (rezBoxesWpCrit <&> (,"rezBoxesWpCrit")) + , (,) one (runPastStart i <&> (,"runPastStart " ++ show i)) + , (,) one (startCrafts >>= roomsContaining [] >>= rezBoxThenRooms <&> + (,"startCrafts >>= roomsContaining [] >>= rezBoxThenRooms")) ] where one = 1::Float @@ -77,16 +80,18 @@ rezBoxStart = do ls <- rezColor return $ treeFromPost [PassDown $ rezBox ls] (UseAll door) -rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room) +rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String) rezBoxesThenWeaponRoom i = do rboxes <- rezBoxes - wroom <- weaponRoom i - return $ rboxes `passUntilUseAll` [wroom] + wroom <- fmap fst $ weaponRoom i + return (rboxes `passUntilUseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i) -rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room) +rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String) rezBoxThenWeaponRoom i = do rcol <- rezColor - treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom i + (wroom,wroomname) <- weaponRoom i + return $ (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom + , "rezBoxThenWeaponRoom "++ show i ++ ":" ++ wroomname) rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room) rezBoxThenRoom r = do