justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Move towards better annotations when generating layouts

Browse Source
This commit is contained in:
justin
2022-05-20 11:14:11 +01:00
parent 887dd547d9
commit 1739d648fe
6 changed files with 52 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+12 -3
View File
@@ -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
src/Dodge/Annotation/Data.hs
+2 -1
View File
@@ -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)]
src/Dodge/Floor.hs
+6 -4
View File
@@ -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
src/Dodge/LevelGen.hs
+8 -3
View File
@@ -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
src/Dodge/Room/Room.hs
+8 -7
View File
@@ -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
src/Dodge/Room/Start.hs
+16 -11
View File
@@ -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