The Great Antarctic Hexcrawl Pt. 4b - Pointcrawl Dungeons Revisited
Once I posted about my pointcrawl dungeon generator I was immediately waylaid by ideas for improving it.
The biggest shortcoming of that initial version is that it generated a pure abstraction with zero spatial information. I assumed I could infer spatial relationships on the fly or use the relative positioning of the output diagrams. That optimism was clearly unfounded:
In play, even an abstracted dungeon needs some spatial cues to aid navigation (or at least some way to distinguish different pathing options in conversation). One of my lodestar inspirations, The Iron Coral from Into The Odd is extremely terse and abstract but takes care to distinguish every exit with a direction:
So, I decided to overhaul my generator and give each room an approximate coordinate in 3d space that could be used to visualize the outputs and weight connection likelihood, like so:
- Determine how many levels the dungeon has (based on the square root of the room count, unchanged from before).
- Define square dimensions for each level by randomly rolling the approximate amount of 'empty' space between rooms (currently generates dungeons that are 1/6th to 4/7ths empty).
- Get the set of all possible coordinate triples and randomly assign one to each room.
# assign rooms to spatial coordinates
n <- nrow(rooms)
z_max <- levels
empty_factor <- runif(1, min=1.2, max=2.5) # approximate amount of empty space
xy_max <- ceiling(sqrt(2*n/z_max))
coords <- expand.grid(x=1:xy_max, y=1:xy_max, z=1:z_max)
room_coords <- coords[sample(1:nrow(coords),n),]
I also overhauled how the rooms get connected. I tried distance-weighted randomization, but discarded it in favor of creating a relative neighborhood graph for each level. This approach has the disadvantage of being deterministic but produces nice-looking, intelligible, and (adequately) Jacquaysed results.
## Fill out relative neighborhood graph for each level
# generate pairs
point_pairs <- expand.grid(test_graph$nodes_df$id, test_graph$nodes_df$id) %>%
filter(Var1 != Var2)
for (i in 1:nrow(point_pairs)){
p1 <- point_pairs[i, 1]
p2 <- point_pairs[i, 2]
if (dungeon_df$z[p1] != dungeon_df$z[p2]){next} # skip if on different floors
if (tryCatch({p1 %in% get_nbrs(test_graph, p2)}, error = function(e) {F})){next} # skip if nodes already connected
pair_dist <- sqrt((dungeon_df$x[p1] - dungeon_df$x[p2])^2 + (dungeon_df$y[p1] - dungeon_df$y[p2])^2 + (dungeon_df$z[p1] - dungeon_df$z[p2])^2)
conn <- T
for (p3 in 1:nrow(dungeon_df)){
if (p3 %in% c(p1, p2)){next}
if (dungeon_df$z[p1] != dungeon_df$z[p3]){next} # skip for different floors
# if p3 is closer to both p1 and p2 than they are to each other, no connection
d1 <- sqrt((dungeon_df$x[p1] - dungeon_df$x[p3])^2 + (dungeon_df$y[p1] - dungeon_df$y[p3])^2 + (dungeon_df$z[p1] - dungeon_df$z[p3])^2)
d2 <- sqrt((dungeon_df$x[p2] - dungeon_df$x[p3])^2 + (dungeon_df$y[p2] - dungeon_df$y[p3])^2 + (dungeon_df$z[p2] - dungeon_df$z[p3])^2)
if (d1<pair_dist&d2<pair_dist){conn <- F}
}
if (conn) {
test_graph <- test_graph %>%
add_edge(from = p1, to = p2, edge_aes = edge_aes(style = 'solid'))
}
}
For inter-level linkages I added some code to create vertical 'staircase' connections where rooms are directly atop each other. If there are no such rooms, the script just picks a random room on level a and then picks a (distance weighted) random room on level b.
# pre-emptively place inter-level staircase connections
if(levels > 1){
for(i in 1:(levels-1)){
lvla <- unique(dungeon_df$level)[i]
lvlb <- unique(dungeon_df$level)[i+1]
conn_ct <- 0
## rooms directly above each other
stair_rooms <- dungeon_df %>%
filter(level%in%c(lvla, lvlb)) %>%
group_by(x,y) %>% filter(n()>1) %>%
ungroup()
if(nrow(stair_rooms)>0){
stair_1 <- sample(stair_rooms$Room, 1)
stair_2 <- stair_rooms %>%
filter(x == stair_rooms$x[stair_rooms$Room==stair_1], y == stair_rooms$y[stair_rooms$Room==stair_1], Room != stair_1)
stair_2 <- stair_2[1]
test_graph <- test_graph %>%
add_edge(from = stair_1, to = stair_2, rel = 'Stairs', edge_aes = edge_aes(style = 'dashed'))
conn_ct <- conn_ct + 1
}
if (conn_ct == 0){ # if no stair room, pick a random room and connect the closest room
stair_1 <- sample(dungeon_df$Room[dungeon_df$level==lvla],1)
elig_rooms <- dungeon_df %>% filter(level == lvlb) %>%
mutate(dist = 1/sqrt((x-dungeon_df$x[dungeon_df$Room==stair_1])^2+(y-dungeon_df$y[dungeon_df$Room==stair_1])^2))
if(nrow(elig_rooms)==1){stair_2<-elig_rooms$Room[1]
}else{
stair_2 <- sample(elig_rooms$Room, 1, prob = elig_rooms$dist)
test_graph <- test_graph %>%
add_edge(from = stair_1, to = stair_2, rel = 'Stairs', edge_aes = edge_aes(
style = 'dashed'
))
}
}
}
}
Lastly, I added a loop to place a few random bonus connections. This is essentially a vestige of an earlier version that weighted connection likelihood by both euclidean distance and number of existing connections:
bonus_connections <- min(sample(1:nrow(dungeon_df),1),sample(1:nrow(dungeon_df),1))
print(bonus_connections)
for (i in 1:bonus_connections){
### pick a random eligible node
eligible_nodes <- test_graph %>% get_node_info() %>% mutate(weight = 1/(1+deg^2))
# pick first node, THEN RECALC TO MAKE NODES IN OTHER LEVELS LESS LIKELY BY DISTANCE!
first_node <- sample(eligible_nodes$id, 1, prob=eligible_nodes$weight)
tryCatch({fn_cnxns <- get_nbrs(test_graph, first_node)}, error= function(e) {fn_cnxns <<- c()})
fn_xyz <- dungeon_df[dungeon_df$Room == first_node, c('x', 'y', 'z')]
eligible_nodes <- eligible_nodes %>% filter(!id%in%c(first_node, fn_cnxns)) %>%
left_join(dungeon_df, by=c('id'='Room')) %>%
mutate(dist = sqrt((x-fn_xyz$x[1])^2 + (y-fn_xyz$y[1])^2 + (z-fn_xyz$z[1])^6)) %>%
mutate(weight = weight/dist)
if(nrow(eligible_nodes)<=0){next}
if(nrow(eligible_nodes) == 1){
second_node <- eligible_nodes$id[1]
} else{second_node <- sample(eligible_nodes$id, 1, prob=eligible_nodes$weight)}
test_graph <- test_graph %>% add_edge(from = first_node, to = second_node, edge_aes = edge_aes(style = 'solid'))
}
I also added some code to label connections (doors between adjacent rooms, corridors between distant ones, traps, locked doors, etc.), and (just for fun) added a chance of generating teleporter connections.
Lastly, I tweaked the layout to just display the rooms spatially with a vertical and horizontal offset between levels. This 'exploded' look isn't very space efficient but is adequately readable relative to other options I tried.
Example Outputs
Current Script
################################################################
### Script to generate pointcrawl dungeons with OD&D stocking
################################################################
r_dungeon <- function(room_count='random', origin='generic'){
if(room_count == 'random'){
room_count <- round(rlnorm(1, meanlog = 3.5, sdlog=0.5), 0)
room_count <- min(room_count, 144)
room_count <- max(room_count, 10)
}
# Randomly partition the rooms into levels
levels = ceiling(sqrt(max(room_count-10,1))*runif(1,0.25,1.4))
# initialize a basic dungeon key table
rooms <- data.frame('Room' = 1:room_count, level=NA, 'Monster'=0, 'Treasure'=0, 'Entrance'=0)
# assign rooms to spatial coordinates
n <- nrow(rooms)
z_max <- levels
empty_factor <- runif(1, min=1.2, max=2.5); print(paste('empty_fac:', empty_factor)) # approximate amount of empty space
xy_max <- ceiling(sqrt(2*n/z_max))
coords <- expand.grid(x=1:xy_max, y=1:xy_max, z=1:z_max)
room_coords <- coords[sample(1:nrow(coords),n),]
rooms <- bind_cols(rooms, room_coords) %>%
mutate(level = z) %>% rowwise() %>%
mutate(Entrance = ifelse(runif(1)<(1/(5*level)), 1, 0)) %>% ungroup() %>% # and give each room a chance of being an entrance
arrange(level) %>% mutate(Room = row_number())
if(sum(rooms$Entrance)==0){ # if we generated zero entrances, pick one on top level
rooms$Entrance[rooms$Room==sample(1:nrow(rooms[rooms$level==min(rooms$level),]), 1)] <- 1
}
# Use OD&D procedure to place treasures and monsters
for(lvl in 1:levels){
lvlrooms <- rooms %>% filter(level==lvl)
while(sum(lvlrooms$Treasure)==0){ #Repeat stocking if no treasure generated
for (i in 1:nrow(lvlrooms)){
a <- sample(1:6, 1)
if(a<3){lvlrooms[i, 'Monster']<-1} # if 1,2 on d6, monster
a <- sample(1:6, 1)
if(lvlrooms[i, 'Monster']==1&&a<4){ # if 1,2,3 in monster room, treasure
lvlrooms[i, 'Treasure']<-1
} else if(a==1&&rooms[i,'Monster']==0){ # if non-monster room, unguarded treasure
lvlrooms[i, 'Treasure']<-1
}
}
}
rooms[rooms$level==lvl,] <- lvlrooms
}
# Generate treasures
rooms$Treasure_desc <- rep('', nrow(rooms))
for (room_id in 1:nrow(rooms)){
if (rooms$Treasure[room_id]==1){
level <- rooms$level[room_id]
if (level == 1){rooms$Treasure_desc[room_id] <- r_gen_eval('[Dungeon_treasure_1]')}
if (level %in% c(2,3)){rooms$Treasure_desc[room_id] <- r_gen_eval('[Dungeon_treasure_2_3]')}
if (level %in% c(4,5)){rooms$Treasure_desc[room_id] <- r_gen_eval('[Dungeon_treasure_4_5]')}
if (level %in% c(6,7)){rooms$Treasure_desc[room_id] <- r_gen_eval('[Dungeon_treasure_6_7]')}
if (level %in% c(8,9)){rooms$Treasure_desc[room_id] <- r_gen_eval('[Dungeon_treasure_8_9]')}
if (level %in% c(10,11,12)){rooms$Treasure_desc[room_id] <- r_gen_eval('[Dungeon_treasure_10_12]')}
if (level >= 13){rooms$Treasure_desc[room_id] <- r_gen_eval('[Dungeon_treasure_13]')}
}
}
rooms <- rooms %>% mutate(cluster = level)
dungeon_df <- rooms %>%
mutate(z = 4*z) # scale z factor to penalize inter-level connections
levels <- length(unique(dungeon_df$z))
test_graph <- create_graph(directed=F) %>%
#add_global_graph_attrs("layout", "fdp", "graph") %>%
add_global_graph_attrs('outputorder', 'nodesfirst', 'graph') %>%
add_nodes_from_table(dungeon_df) %>%
set_node_attrs(node_attr = fontname, values = 'TT2020 Style B') %>%
set_node_attrs(node_attr = fillcolor, values = 'gray90') %>%
set_node_attrs(node_attr = shape, values = 'square') %>%
set_node_attrs(node_attr = fontcolor, values = 'black') %>%
set_node_attrs(node_attr = penwidth, values = 3) %>%
select_nodes(conditions = Monster == 1) %>%
set_node_attrs_ws(node_attr = fillcolor, value = '#eda495') %>%
clear_selection() %>%
select_nodes(conditions = Treasure == 1) %>%
set_node_attrs_ws(node_attr = color, value = 'darkgoldenrod')%>%
clear_selection() %>%
select_nodes(conditions = Entrance == 1) %>%
set_node_attrs_ws(node_attr = peripheries, value = 2) %>%
clear_selection()
# pre-emptively place inter-level staircase connections
if(levels > 1){
for(i in 1:(levels-1)){
lvla <- unique(dungeon_df$level)[i]
lvlb <- unique(dungeon_df$level)[i+1]
conn_ct <- 0
## rooms directly above each other
stair_rooms <- dungeon_df %>%
filter(level%in%c(lvla, lvlb)) %>%
group_by(x,y) %>% filter(n()>1) %>%
ungroup()
if(nrow(stair_rooms)>0){
stair_1 <- sample(stair_rooms$Room, 1)
stair_2 <- stair_rooms %>%
filter(x == stair_rooms$x[stair_rooms$Room==stair_1], y == stair_rooms$y[stair_rooms$Room==stair_1], Room != stair_1)
stair_2 <- stair_2[1]
test_graph <- test_graph %>%
add_edge(from = stair_1, to = stair_2, rel = 'Stairs', edge_aes = edge_aes(style = 'dashed'))
conn_ct <- conn_ct + 1
}
if (conn_ct == 0){ # if no stair room, pick a random room and connect the closest room
stair_1 <- sample(dungeon_df$Room[dungeon_df$level==lvla],1)
elig_rooms <- dungeon_df %>% filter(level == lvlb) %>%
mutate(dist = 1/sqrt((x-dungeon_df$x[dungeon_df$Room==stair_1])^2+(y-dungeon_df$y[dungeon_df$Room==stair_1])^2))
if(nrow(elig_rooms)==1){stair_2<-elig_rooms$Room[1]
}else{
stair_2 <- sample(elig_rooms$Room, 1, prob = elig_rooms$dist)
test_graph <- test_graph %>%
add_edge(from = stair_1, to = stair_2, rel = 'Stairs', edge_aes = edge_aes(style = 'dashed'))
}
}
}
}
## Fill out relative neighborhood graph for each level
# generate pairs
point_pairs <- expand.grid(test_graph$nodes_df$id, test_graph$nodes_df$id) %>%
filter(Var1 != Var2)
for (i in 1:nrow(point_pairs)){
p1 <- point_pairs[i, 1]
p2 <- point_pairs[i, 2]
if (dungeon_df$z[p1] != dungeon_df$z[p2]){next} # skip if on different floors
if (tryCatch({p1 %in% get_nbrs(test_graph, p2)}, error = function(e) {F})){next} # skip if nodes already connected
pair_dist <- sqrt((dungeon_df$x[p1] - dungeon_df$x[p2])^2 + (dungeon_df$y[p1] - dungeon_df$y[p2])^2 + (dungeon_df$z[p1] - dungeon_df$z[p2])^2)
conn <- T
for (p3 in 1:nrow(dungeon_df)){
if (p3 %in% c(p1, p2)){next}
if (dungeon_df$z[p1] != dungeon_df$z[p3]){next} # skip for different floors
# if p3 is closer to both p1 and p2 than they are to each other, no connection
d1 <- sqrt((dungeon_df$x[p1] - dungeon_df$x[p3])^2 + (dungeon_df$y[p1] - dungeon_df$y[p3])^2 + (dungeon_df$z[p1] - dungeon_df$z[p3])^2)
d2 <- sqrt((dungeon_df$x[p2] - dungeon_df$x[p3])^2 + (dungeon_df$y[p2] - dungeon_df$y[p3])^2 + (dungeon_df$z[p2] - dungeon_df$z[p3])^2)
if (d1<pair_dist&d2<pair_dist){conn <- F}
}
if (conn) {
if(pair_dist == 1){node_rel <- sample(c('D', 'D', 'D', 'Locked', 'Locked', 'Open'), 1)
} else {node_rel <- sample(c('C', 'C', 'C', 'C', 'Trap', 'Obstruction'), 1)}
test_graph <- test_graph %>%
add_edge(from = p1, to = p2, rel=node_rel, edge_aes = edge_aes(style = 'solid'))
}
}
# flesh out graph with extra connections
bonus_connections <- min(sample(1:nrow(dungeon_df),1),sample(1:nrow(dungeon_df),1), sample(1:nrow(dungeon_df),1)); print(bonus_connections)
for (i in 1:bonus_connections){
### pick a random eligible node
eligible_nodes <- test_graph %>% get_node_info() %>% mutate(weight = 1/(1+deg^2))
# pick first node, THEN RECALC TO MAKE NODES IN OTHER LEVELS LESS LIKELY BY DISTANCE!!
first_node <- sample(eligible_nodes$id, 1, prob=eligible_nodes$weight)
tryCatch({fn_cnxns <- get_nbrs(test_graph, first_node)}, error= function(e) {fn_cnxns <<- c()})
fn_xyz <- dungeon_df[dungeon_df$Room == first_node, c('x', 'y', 'z')]
eligible_nodes <- eligible_nodes %>% filter(!id%in%c(first_node, fn_cnxns)) %>%
left_join(dungeon_df, by=c('id'='Room')) %>%
mutate(dist = sqrt((x-fn_xyz$x[1])^2 + (y-fn_xyz$y[1])^2 + (z-fn_xyz$z[1])^6)) %>%
mutate(weight = weight/dist)
if(nrow(eligible_nodes)<=0){next}
if(nrow(eligible_nodes) == 1){
second_node <- eligible_nodes$id[1]
} else{second_node <- sample(eligible_nodes$id, 1, prob=eligible_nodes$weight)}
# corridor type by distance
pair_dist <- eligible_nodes$dist[eligible_nodes$id == second_node]
if(pair_dist == 1){node_rel <- sample(c('D', 'D', 'D', 'Locked', 'Locked', 'Open'), 1); sty = 'solid'
} else {node_rel <- sample(c('C', 'C', 'C', 'C', 'Trap', 'Obstr.'), 1); sty = 'solid'}
# if crossing floors, stairs
if(dungeon_df$z[dungeon_df$Room==first_node] != dungeon_df$z[dungeon_df$Room==second_node]){node_rel <- 'stairs'; sty = 'dashed'}
test_graph <- test_graph %>% add_edge(from = first_node, to = second_node, rel = node_rel, edge_aes = edge_aes(style = sty))
}
## Layout adjust
test_graph <- test_graph %>%
set_edge_attrs(fontname, 'TT2020 Style E') %>%
mutate_edge_attrs(label = rel) %>%
mutate_node_attrs(y = y - ((level-1)*xy_max*1.1)) %>%
mutate_node_attrs(x = x + ((level-1)*xy_max*0.75))
# teleporters
if(runif(1,0,1) < (n/500)){
tele_count <- sample(1:ceiling(sqrt(n)), 1)
for(i in 1:tele_count){
tele_rooms <- sample(1:n, 2)
test_graph <- test_graph %>%
add_edge(from = tele_rooms[1], to = tele_rooms[2], rel='Teleporter', edge_aes = edge_aes(label = 'Teleporter', color = 'skyblue', style = 'dotted'))
}
}
return(test_graph)
}