Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss
Proposed New Level Type: Densely Packed Rooms, with Corridors
206 views
Skip to first unread message
Jonadab the Unsightly One
Nov 30, 2012, 7:39:01 AM11/30/12
to
#!/usr/bin/perl
# -*- cperl -*-
# This is a Perl program that generates a proposed new type
# of NetHack level, consisting of a denser packing of rooms
# and corridors than the traditional one. This is strictly
# experimental, and of course this Perl code will not
# integrate into NetHack, so in order to be used it would
# need to be reimplemented in C and integrated into
# NetHack's existing level-generation code.
# If implemented, these types of levels could be used in
# custom dungeon content, in special levels (e.g., quest
# filler levels for proposed new roles), and potentially
# in Gehennom to replace some of the maze levels.
# Note that these levels should NOT be used very early in
# the dungeons, because they may contain disconnected areas
# that can only be reached by digging or teleport, as well
# as water and/or lava that may need to be traversed in some
# cases. Also, the special rooms contain monsters that a
# pre-quest, pre-castle character should not have to face.
# In other words, these are strictly late-game levels.
# Don't worry if the choices of monsters seem odd. Except
# for special rooms, this script does not attempt realistic
# monster generation, because the intention is that the
# existing monster generation code be used. So while this
# script does pepper the levels with random monsters, that's
# just so they don't look totally bare.
# Other than that, there are still a few bugs to work out
# (e.g., doors on the corners of rooms shouldn't happen),
# but I think it's reached the point where it's worth
# soliciting feedback...
# If the idea of new kinds of levels to mix in with the
# mazes in Gehennom interests you, please run this Perl
# script a few times and let me know what you think.
# Specific suggestions are welcome.
my %arg = @ARGV;
my $debug = $arg{debug} || 3;
my $maxrows = $arg{maxrows} || 24;
my $maxcols = $arg{maxcols} || 65 + int rand(4);
my $minroomwidth = $arg{minroomwidth} || 2 + int rand(3);
my $minroomheight = $arg{minroomheight} || 2 + int rand(2);
my $minrectwidth = $minroomwidth + 2 + int rand(3);
my $minrectheight = $minroomheight + 2;# + int rand(1);
print "Min rect: $minrectwidth x $minrectheight"
. "; min room: $minroomwidth x $minroomheight\n" if $debug;
my $maxrectwidth = $arg{maxrectwidth} || 11 + int rand(5);
my $maxrectheight = $arg{maxrectheight} || 6 + int rand(3);
my $roomprob = $arg{roomprob} || 90;
my $secretprob = $arg{secretprob} || 30;
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $floorchar = $arg{floorchar} || '.';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $nwcornerchar = $arg{nwcornerchar} || '-';
my $necornerchar = $arg{necornerchar} || '-';
my $swcornerchar = $arg{swcornerchar} || '-';
my $secornerchar = $arg{secornerchar} || '-';
my $errorchar = $arg{errorchar} || 'E';
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
my $wallcolor = $arg{wallcolor} || 'white on_black';
my $floorcolor = $arg{floorcolor} || 'reset';
my $doorcolor = $arg{doorcolor} || 'yellow on_black';
my $sdoorcolor = $arg{sdoorcolor} || $wallcolor;
my $corridorcolor = $arg{corridorcolor} || 'reset';
my $corridorfreq = $arg{corridorfreq} || 2 + int rand 2;
my $corridortwist = $arg{corridortwist} || 12;
my $connectretry = $arg{connectretry} || 3;
my $mergethreshold= $arg{mergethreshold}|| 2;
my $mergeprob = $arg{mergeprob} || 45;
my $fountainprob = $arg{fountainprob} || 7;
my $maxfountains = $arg{maxfountains} || 8;
my $maxroomfounts = $arg{maxroomfounts} || 4;
my $staircolor = $arg{staircolor} || 'bold white';
my $upstaircolor = $arg{upstaircolor} || $staircolor;
my $downstaircolor= $arg{downstaircolor}|| $staircolor;
my $fountainchar = $arg{fountainchar} || '{';
my $fountaincolor = $arg{fountaincolor} || 'bold blue';
my $sinkprob = $arg{sinkprob} || 5;
my $maxsinks = $arg{maxsinks} || 6;
my $maxroomsinks = $arg{maxroomsinks} || 1;
my $sinkchar = $arg{sinkchar} || '#';
my $sinkcolor = $arg{sinkcolor} || 'bold cyan';
my $altarprob = $arg{altarprob} || 3;
my $maxaltars = $arg{maxaltars} || 2;
my $priestprob = $arg{priestprob} || 30;
my $altarchar = $arg{altarchar} || '_';
my $altarcolor = $arg{altarcolor} || 'bold yellow';
my $priestchar = $arg{priestchar} || '@';
my $priestcolor = $arg{priestcolor} || 'bold white';
my $graveprob = $arg{graveprob} || 5;
my $maxgraves = $arg{maxgraves} || 3;
my $gravechar = $arg{gravechar} || '|';
my $gravecolor = $arg{gravecolor} || 'bold white on_black';
my $poolprob = $arg{poolprob} || 7;
my $morepoolprob = $arg{morepoolprob} || 65;
my $maxpools = $arg{maxpools} || 15;
my $maxroompools = $arg{maxroompools} || 9;
my $poolchar = $arg{poolchar} || '}';
my $poolcolor = $arg{poolcolor} || 'bold cyan on_blue';
my $lavaprob = $arg{lavaprob} || 12;
my $morelavaprob = $arg{morelavaprob} || 85;
my $maxlava = $arg{maxlava} || 9;
my $maxroomlava = $arg{maxroomlava} || 9;
my $lavachar = $arg{lavachar} || '}';
my $lavacolor = $arg{lavacolor} || 'bold red';
my $specialprob = $arg{specialprob} || 7;
my $statuechar = $arg{statuechar} || "`";
my $statuecolor = $arg{statuecolor} || 'reset';
my $statuespacing = $arg{statuespacing} || undef;
my $monsterprob = $arg{monsterprob} || 45;
my $mongroupprob = $arg{mongroupprob} || 5;
my $moremonstprob = $arg{moremonstprob} || 75;
my $maxgroupsize = $arg{maxgroupsize} || 9;
my $maxroommonst = $arg{maxroommonst} || 11;
my @randmonst = (
# This list is not intended to accurately
# reflect what would actually happen in
# the game. It's just a sampling so the
# levels can look approximately normal.
# (The proposed dense-room-and-corridor
# levels, if implemented, would use the
# existing random monster generation code.)
['water demon', '&', 'blue'],
['horned devil', '&', 'bold red'],
['succubus', '&', 'reset'],
['incubus', '&', 'reset'],
['barbed devil', '&', 'red'],
['vrock', '&', 'red'],
['hezrou', '&', 'red'],
['bone devil', '&', 'white'],
['ice devil', '&', 'bold white'],
['nalfeshnee', '&', 'red'],
['pit fiend', '&', 'red'],
['balrog', '&', 'red'],
['fire ant', 'a', 'red'],
['hell hound', 'd', 'red'],
['tiger', 'f', 'bold yellow'],
['gremlin', 'g', 'green'],
['gargoyle', 'g', 'yellow'],
['winged gargoyle', 'g', 'magenta'],
['mind flayer', 'h', 'bold magenta'],
['ochre jelly', 'j', 'yellow'],
['giant mimic', 'm', 'magenta'],
['mountain nymph', 'n', 'yellow'],
['Uruk-hai', 'o', 'bold black'],
['orc-captain', 'o', 'magenta'],
['wumpus', 'q', 'cyan'],
['titanothere', 'q', 'reset'],
['mastodon', 'q', 'bold black'],
['trapper', 't', 'green'],
['purple worm', 'w', 'bold magenta'],
['xan', 'x', 'red'],
['zruty', 'z', 'yellow'],
['vampire bat', 'B', 'bold black'],
['stalker', 'E', 'bold white'],
['air elemental', 'E', 'bold cyan'],
['fire elemental', 'E', 'bold yellow'],
['earth elemental', 'E', 'yellow'],
['water elemental', 'E', 'bold blue'],
['shrieker', 'F', 'bold magenta'],
['titan', 'H', 'bold magenta'],
['storm giant', 'H', 'bold blue'],
['jabberwock', 'J', 'bold red'],
['arch-lich', 'L', 'bold magenta'],
['demilich', 'L', 'red'],
['golden naga', 'N', 'bold yellow'],
['ogre king', 'O', 'magenta'],
['green slime', 'P', 'bold green'],
['disenchanter', 'R', 'blue'],
['Olog-hai', 'T', 'bold magenta'],
['umber hulk', 'U', 'yellow'],
['wraith', 'W', 'bold black'],
['xorn', 'X', 'yellow'],
['sasquatch', 'Y', 'reset'],
['iron golem', "'", 'cyan'],
['ghost', ' ', 'bold black'],
);
$|=1;
while ($maxrectwidth < $minrectwidth + 2) {
warn "Max rect width ("
. $maxrectwidth . ") too small; adjusting.";
++$maxrectwidth;
}
while ($maxrectheight < $minrectheight + 1) {
warn "Max rect height ("
. $maxrectheight. ") too small; adjusting.";
++$maxrectheight;
}
die "Not enough columns to fit a max-size rect."
if $maxcols < $maxrectwidth;
die "Not enough rows to fit a max-size rect."
if $maxrows < $maxrectheight;
use Term::ANSIColor;
# First, lay out a basic grid of rectangles:
my @cellcol;
my @rect; {
my $cellx = 0;
my $x = 0;
while ($x + $maxrectwidth <= $maxcols) {
my $width = $minrectwidth
+ int rand($maxrectwidth - $minrectwidth);
my $startx = $x;
$x += $width;
my $endx = $x;
$cellcol[$cellx++] = +{
cellx => $cellx,
startx => $startx,
stopx => $startx + $width,
};
$x++; # Don't overlap by one.
}
my ($y, $celly, $rect) = (0, 0, 0);
while ($y + $maxrectheight <= $maxrows) {
my $height = $minrectheight
+ int rand($maxrectheight - $minrectheight);
my $starty = $y;
$y += $height;
my $endy = $y;
$y++;
my ($x, $cellx) = (0, 0);
foreach my $cellcol (@cellcol) {
my $width = $minrectwidth
+ int rand($maxrectwidth - $minrectwidth);
my $startx = $x;
$x += $width;
my $endx = $x;
$rect[$celly][$cellx] = +{
rect => ++$rect,
celly => $celly,
starty => $starty,
stopy => $starty + $height,
maxy => $maxrows,
maxx => $maxcols,
miny => 0,
minx => 0,
map { $_ =>
${$cellcol[$cellx]}{$_}
} qw(cellx startx stopx),
};
$cellx++;
}
$celly++;
}
}
if ($debug > 4) {
my @stageone = buildlevel(@rect);
#use Data::Dumper; print Dumper(\@rect);
printlevel(level => \@stageone,
title => "Stage One",
debug => $debug,
);
}
print "Minimum rect dimensions: $minrectheight,$minrectwidth\n"
if $debug > 4;
# That's a start, but it's a bit too regular. The cells in
# each row are the same height and line up at the top and
# bottom, and the cells in each column are the same width
# and line up at left and right. To fix this, we want to
# push some of their borders around a bit.
# The trick is deciding which borders to push in a way that
# doesn't lead to overlapping. If a cell is enlarged
# southward, for example, then the cell to the southwest
# cannot be enlarged eastward: its eastern side must be
# capped at a maximum that leaves it not overlapping.
# Similarly, the cell to the southeast will have its
# western edge limited.
# To support this, we introduce four new fields to each
# cell: minx, maxx, miny, maxy. They will all start at
# undef, meaning the cell is limited only by its immediate
# neighbors (vertically and horizontally). When a border
# is pushed, these limits will be checked first (to see
# if the push is allowed) and then adjusted after (to
# prevent subsequent pushes from overlapping).
# There are scalar @cellcol columns of cells, numbered from
# 0 to ((scalar @cellcol) - 1) and scalar @rect rows of
# cells, numberd from 0 to ((scalar @rect) - 1). In order
# to prevents systematic bias, we want to consider these
# borders in random order. To do that, we need a list:
my @border = (
# Vertical borders:
(map {
my $y = $_; # y coord of second/bottom cell
map {
my $x = $_; # x coord of both cells
+{
direction => 'y',
cellone => [ $y - 1, $x ],
celltwo => [ $y, $x ],
}
} 0 .. ((scalar @cellcol) - 1);
} 1 .. ((scalar @rect) - 1)),
# Horizontal borders:
(map {
my $y = $_; # y coord of both cells
map {
my $x = $_; # x coord of second/right cell
+{
direction => 'x',
cellone => [ $y, $x - 1 ],
celltwo => [ $y, $x ],
}
} 1 .. ((scalar @cellcol) - 1);
} 0 .. ((scalar @rect) - 1),
));
# Put that list in a random order:
@border = map {
$$_[0]
} sort {
$$a[1] <=> $$b[1]
} map {
[ $_ => rand(1087) ]
} @border;
my @maybemerge;
# Now we got through the list of borders...
for my $border (@border) {
my $oney = $$border{cellone}[0]; # This
my $onex = $$border{cellone}[1]; # saves
my $twoy = $$border{celltwo}[0]; # confusion
my $twox = $$border{celltwo}[1]; # below.
print "Considering border between cells $oney,$onex"
. " and $twoy,$twox\n" if $debug > 6;
if ($$border{direction} eq 'y') {
# The two cells have different y coords, same x.
if (rand(100)>= 50) {
# Try to enlarge the first cell (shrink the second).
print " Want to grow south.\n" if $debug > 7;
# First off, the second cell can't be shrunk to less
# than the minimum height:
my $twocurrentheight
= $rect[$twoy][$twox]{stopy}
- $rect[$twoy][$twox]{starty};
my $maxshrink = $twocurrentheight - $minrectheight;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $maxy = $rect[$oney][$onex]{stopy} + $maxshrink;
if ($rect[$oney][$onex]{maxy} > $maxy) {
$rect[$oney][$onex]{maxy} = $maxy;
} else {
$maxy = $rect[$oney][$onex]{maxy};
}
my $maxgrow = $maxy - $rect[$oney][$onex]{stopy};
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print " Growing cell $oney,$onex south by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopy} += $grow;
$rect[$twoy][$twox]{starty} += $grow;
push @maybemerge, $border
if abs($grow) >= $mergethreshold;
# Limit nearby cells so they won't overlap:
if (($twox >= 1)
and ($rect[$twoy][$twox - 1]{maxx}
>= $rect[$oney][$onex]{startx})) {
$rect[$twoy][$twox - 1]{maxx} =
$rect[$oney][$onex]{startx} - 1;
}
if (($twox + 1 < (scalar @cellcol))
and ($rect[$twoy][$twox + 1]{minx}
<= $rect[$oney][$onex]{startx})) {
$rect[$twoy][$twox + 1]{minx} =
$rect[$oney][$onex]{startx} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $oney,$onex South",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $oney,$onex south.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
max => $maxy,
cur => $twocurrentheight,
});
}
} else {
# Try to enlarge the second cell (shrink the first).
print " Want to grow north.\n" if $debug > 7;
# First off, the first cell can't be shrunk to less
# than the minimum height:
my $onecurrentheight
= $rect[$oney][$onex]{stopy}
- $rect[$oney][$onex]{starty};
my $maxshrink = $onecurrentheight - $minrectheight;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $miny = $rect[$twoy][$twox]{starty} - $maxshrink;
if ($rect[$twoy][$twox]{miny} < $miny) {
$rect[$twoy][$twox]{miny} = $miny;
} else {
$miny = $rect[$twoy][$twox]{miny};
}
my $maxgrow = $rect[$twoy][$twox]{starty} - $miny;
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print " Growing cell $twoy,$twox north by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopy} -= $grow;
$rect[$twoy][$twox]{starty} -= $grow;
# Limit nearby cells so they won't overlap:
if (($onex >= 1)
and ($rect[$oney][$onex - 1]{maxx}
>= $rect[$twoy][$twox]{startx})) {
$rect[$oney][$onex - 1]{maxx} =
$rect[$twoy][$twox]{startx} - 1;
}
if (($onex + 1 < (scalar @cellcol))
and ($rect[$oney][$onex + 1]{minx}
<= $rect[$twoy][$twox]{startx})) {
$rect[$oney][$onex + 1]{maxy} =
$rect[$twoy][$twox]{startx} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $twoy,$twox North",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $twoy,$twox north.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
min => $miny,
cur => $onecurrentheight,
});
}
}
} elsif ($$border{direction} eq 'x') {
# The two cells have different x coords, same y.
if (rand(100)>= 50) {
# Try to enlarge the first cell (shrink the second).
print " Want to grow east.\n" if $debug > 7;
# First off, the second cell can't be shrunk to less
# than the minimum width:
my $twocurrentwidth
= $rect[$twoy][$twox]{stopx}
- $rect[$twoy][$twox]{startx};
my $maxshrink = $twocurrentwidth - $minrectwidth;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $maxx = $rect[$oney][$onex]{stopx} + $maxshrink;
# TODO: Not entirely sure but what catycorner rects
# should also be checked.
if ($rect[$oney][$onex]{maxx} > $maxx) {
$rect[$oney][$onex]{maxx} = $maxx;
} else {
$maxx = $rect[$oney][$onex]{maxx};
}
my $maxgrow = $maxx - $rect[$oney][$onex]{stopx};
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print " Growing cell $oney,$onex east by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopx} += $grow;
$rect[$twoy][$twox]{startx} += $grow;
push @maybemerge, $border
if abs($grow) >= $mergethreshold;
# Limit nearby cells so they won't overlap:
if (($twoy >= 1)
and ($rect[$twoy - 1][$twox]{maxy}
>= $rect[$oney][$onex]{starty})) {
$rect[$twoy - 1][$twox]{maxy} =
$rect[$oney][$onex]{starty} - 1;
}
if (($twoy + 1 < (scalar @rect))
and ($rect[$twoy + 1][$twox]{miny}
<= $rect[$oney][$onex]{stopy})) {
$rect[$twoy + 1][$twox]{miny} =
$rect[$oney][$onex]{stopy} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $oney,$onex East",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $oney,$onex east.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
max => $maxx,
cur => $twocurrentwidth,
});
}
} else {
# Try to enlarge the first cell (shrink the second).
print " Want to grow west.\n" if $debug > 7;
# First off, the first cell can't be shrunk to less
# than the minimum width:
my $onecurrentwidth
= $rect[$oney][$onex]{stopx}
- $rect[$oney][$onex]{startx};
my $maxshrink = $onecurrentwidth - $minrectwidth;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $minx = $rect[$twoy][$twox]{stopx} - $maxshrink;
# TODO: Not entirely sure but what catycorner rects
# should also be checked.
if ($rect[$twoy][$twox]{minx} < $minx) {
$rect[$twoy][$twox]{minx} = $minx;
} else {
$minx = $rect[$twoy][$twox]{minx};
}
my $maxgrow = $rect[$twoy][$twox]{startx} - $minx;
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print "Growing cell $twoy,$twox west by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopx} -= $grow;
$rect[$twoy][$twox]{startx} -= $grow;
# Limit nearby cells so they won't overlap:
if (($oney >= 1)
and ($rect[$oney - 1][$onex]{maxy}
>= $rect[$twoy][$twox]{starty})) {
$rect[$oney - 1][$onex]{maxy}
= $rect[$twoy][$twox]{starty} - 1;
}
if (($oney + 1 < (scalar @rect))
and ($rect[$oney + 1][$onex]{miny}
<= $rect[$twoy][$twox]{starty})) {
$rect[$oney + 1][$onex]{miny}
= $rect[$twoy][$twox]{starty} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $twoy,$twox West",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $twoy,$twox west.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
min => $minx,
cur => $onecurrentwidth,
});
}}
} else {
die "Impossible border direction: '$$border{direction}'";
}
}
if ($debug > 4) {
my @stagetwo = buildlevel(@rect);
printlevel(level => \@stagetwo,
title => "Stage Two",
debug => $debug);
}
# Combine a few adjacent rectangles if possible:
# Start by putting the list in a new random order:
print "There are " . @maybemerge
. " cell pairs to consider merging.\n"
if $debug > 2;
@maybemerge = map {
$$_[0]
} sort {
$$a[1] <=> $$b[1]
} map {
[ $_ => rand(1087) ]
} @maybemerge;
for my $pair (@maybemerge) {
my $oney = $$pair{cellone}[0]; # This
my $onex = $$pair{cellone}[1]; # saves
my $twoy = $$pair{celltwo}[0]; # confusion
my $twox = $$pair{celltwo}[1]; # below.
my $rone = $rect[$oney][$onex];
my $rtwo = $rect[$twoy][$twox];
if ((ref $rone) and (ref $rtwo)) {
print "Considering merging cells $oney,$onex"
. " and $twoy,$twox" if $debug > 6;
if (rand(100)<= $mergeprob) {
print ", decided to try.\n" if $debug > 6;
if ($$border{direction} eq 'y') {
# The two cells have different y coords, same x.
my $newstartx = $$rone{startx};
my $newstopx = $$rone{stopx};
$newstartx = $$rtwo{startx}
if $$rtwo{startx} > $newstartx;
$newstopx = $$rtwo{stopx}
if $$rtwo{stopx} < $newstopx;
if ($newstopx - $newstartx >= $minrectwidth) {
my $newstarty = $$rone{starty};
my $newstopy = $$rtwo{starty};
$rect[$oney][$onex] = +{
rect => $$rone{rect},
celly => $oney,
twoy => $twoy,
cellx => $onex,
starty => $newstarty,
stopy => $newstopy,
startx => $newstartx,
stopx => $newstartx,
merged => 'y',
};
push @purged, $rect[$twoy][$twox];
$rect[$twoy][$twox] = undef;
print "Merged vertically: $newstarty,$newstartx"
. " $newstopy,$newstopx.\n" if $debug >= 3;
} else {
print "New rect would not be wide enough "
. "($newstopx - $newstartx < $minrectwidth).\n"
if $debug > 6;
}
} else {
# The two cells have different x coords, same y.
my $newstarty = $$rone{starty};
my $newstopy = $$rone{stopy};
$newstarty = $$rtwo{starty}
if $$rtwo{starty} > $newstarty;
$newstopy = $$rtwo{stopy}
if $$rtwo{stopy} < $newstopy;
if ($newstopy - $newstarty >= $minrectheight) {
my $newstartx = $$rone{startx};
my $newstopx = $$rtwo{stopx};
$rect[$oney][$onex] = +{
rect => $$rone{rect},
celly => $oney,
cellx => $onex,
twox => $twox,
starty => $newstarty,
stopy => $newstopy,
startx => $newstartx,
stopx => $newstopx,
merged => 'x',
};
push @purged, $rect[$twoy][$twox];
$rect[$twoy][$twox] = undef;
print "Merged horizontally: $newstarty,$newstartx"
. " $newstopy,$newstopx.\n" if $debug >= 3;
} else {
print "New rect would not be tall enough "
. "($newstopy - $newstarty < $minrectheight.)\n"
if $debug > 6;
}
}
} else {
print ", decided against it.\n" if $debug > 6;
}
}}
use Data::Dumper; print Dumper(+{ purged => \@purged })
if $debug > 7;
my @finalstage = buildlevel(@rect);
printlevel(level => \@finalstage);
sub buildlevel {
my @r = @_;
my ($maxfloorx, $maxfloory) = (0,0);
my @pos = map { # Initialize to blank:
[ map { +{ char => $blankchar,
terr => 'rock (by default)',
colr => 'reset',
furn => [],
objs => [],
mons => undef,
rect => undef,
room => undef,
} } 1 .. $maxcols ],
} 1 .. $maxrows;
print "The pos array has " . @pos . "rows after init.\n"
if $debug > 9;
for my $celly ( 0 .. ((scalar @r) - 1)) {
for my $cellx ( 0 .. ((scalar @cellcol) - 1)) {
my $rect = $r[$celly][$cellx];
if (ref $rect) {
my $rdig = $$rect{rect} % 10;
warn "Mismatch on celly" if $$rect{celly} ne $celly;
warn "Mismatch on cellx" if $$rect{cellx} ne $cellx;
# Step One: Assign Rectangle
for my $y ($$rect{starty} .. $$rect{stopy}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
$pos[$y][$x]{rect} = $$rect{rect};
$pos[$y][$x]{char} = $rdig if $debug > 12;
}
}
if (rand(100)<=$roomprob) {
# Step Two: Calculate Room Size and Position:
my $rectwidth = $$rect{stopx} - $$rect{startx};
my $rectheight = $$rect{stopy} - $$rect{starty};
# Leave room for at least one corridor tile:
my $maxroomwidth = $rectwidth - 1
- int rand rand ($rectwidth - $minroomwidth);
my $maxroomheight = $rectheight - 1
- int rand rand ($rectheight - $minroomheight);
my $roomwidth = $maxroomwidth
- int rand int rand ($maxroomwidth - $minroomwidth);
my $roomheight = $maxroomheight
- int rand int rand ($maxroomheight - $minroomheight);
my $xslop = $rectwidth - $roomwidth;
my $yslop = $rectheight - $roomheight;
my $roomstartx = $$rect{startx} + int rand $xslop;
my $roomstarty = $$rect{starty} + int rand $yslop;
my $roomstopx = $roomstartx + $roomwidth;
my $roomstopy = $roomstarty + $roomheight;
$r[$celly][$cellx]{roomgeom} = +{
startx => $roomstartx,
starty => $roomstarty,
stopx => $roomstopx,
stopy => $roomstopy,
width => $roomwidth,
height => $roomheight,
};
# Step Three: Place Floor
my $fc = ($debug > 7) ? ($$rect{rect}%10) : $floorchar;
for my $y (($roomstarty + 1) .. ($roomstopy - 1)) {
for my $x (($roomstartx + 1) .. $roomstopx - 1) {
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{char} = $fc;
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{room} = $$rect{rect};
$maxfloory = $y if $y > $maxfloory;
$maxfloorx = $x if $x > $maxfloorx;
}}
# Step Four: Place Walls
for my $y ($roomstarty .. $roomstopy) {
for my $x ($roomstartx, $roomstopx) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} = $$rect{rect};
}}
for my $y ($roomstarty, $roomstopy) {
for my $x ($roomstartx .. $roomstopx) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} = $$rect{rect};
}}
$pos[$roomstarty][$roomstartx]{char} = $nwcornerchar;
$pos[$roomstarty][$roomstopx]{char} = $necornerchar;
$pos[$roomstopy][$roomstartx]{char} = $swcornerchar;
$pos[$roomstopy][$roomstopx]{char} = $secornerchar;
$pos[$roomstarty][$roomstartx]{crnr} = 1;
$pos[$roomstarty][$roomstopx]{crnr} = 1;
$pos[$roomstopy][$roomstartx]{crnr} = 1;
$pos[$roomstopy][$roomstopx]{crnr} = 1;
} else {
$r[$celly][$cellx]{roomgeom} = undef;
}}
}}
my @roomcell = sort { $$a[2] <=> $$b[2] } map {
my $celly = $_;
map {
my $cellx = $_;
[$celly, $cellx, rand(739)];
} 0 .. ((scalar @cellcol) - 1);
} 0 .. ((scalar @r) - 1);
# Step Five: Place Contents:
{
my ($didup, $diddown) = (0, 0);
my ($fountcount, $sinkcount, $altarcount, $gravecount,
$poolcount, $lavacount) = (0, 0, 0, 0, 0, 0);
for my $cell (@roomcell) {
my ($celly, $cellx) = @$cell;
my $rect = $r[$celly][$cellx];
if (ref $rect) {
print " R$$rect{rect}" if $debug > 13;
my ($roomfountcount, $roomsinkcount,
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
# Step 5A: Place Furniture
my $special;
if (not $didup) {
$didup = placefurniture(\@r, \@pos, $celly, $cellx,
'stairs', '<', $upstaircolor);
if ($didup and ($debug > 6)) {
print color $staircolor;
print '<';
print color 'reset';
}
} elsif (not $diddown) {
$diddown = placefurniture(\@r, \@pos, $celly, $cellx,
'stairs', '>', $downstaircolor);
if ($diddown and ($debug > 6)) {
print color $staircolor;
print '>';
print color 'reset';
}
} else {
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
if (rand(100)<=60) {
$special = 'dragon lair';
} # TODO: more special-room options
}}
if ($special eq 'statue hall') {
my @bordertile;
my $statuecount;
push @bordertile, $_ for map {
my $x = $_;
[$$rect{roomgeom}{starty} + 1, $x]
} ($$rect{roomgeom}{startx} + 1)
.. ($$rect{roomgeom}{stopx} - 1);
push @bordertile, $_ for map {
my $y = $_;
[$y, $$rect{roomgeom}{stopx} - 1]
} ($$rect{roomgeom}{starty} + 2)
.. ($$rect{roomgeom}{stopy} - 2);
push @bordertile, $_ for map {
my $x = $_;
[$$rect{roomgeom}{stopy} - 1, $x]
} reverse (($$rect{roomgeom}{startx} + 1)
.. ($$rect{roomgeom}{stopx} - 1));
push @bordertile, $_ for map {
my $y = $_;
[$y, $$rect{roomgeom}{startx} + 1]
} reverse (($$rect{roomgeom}{starty} + 2)
.. ($$rect{roomgeom}{stopy} - 2));
my $spacing = (defined $statuespacing)
? $statuespacing : ((int rand(5)) ? 1 : rand(3));
while (scalar @bordertile) {
my $tile = shift @bordertile;
placefurniture(\@r, \@pos, $celly, $cellx,
'statue', $statuechar,
$statuecolor, @$tile);
for (1 .. $spacing) {
shift @bordertile if scalar @bordertile;
}}
# TODO: also place some traps in the room.
} elsif ($special eq 'dragon lair') {
my %dragoncolor = (black => 'bold black',
red => 'bold red',
blue => 'blue',
gray => 'white');
my @color = keys %dragoncolor;
my $color = $color[rand @color];
placemonster(\@r, \@pos, $celly, $cellx,
"great $color dragon",
'D', $dragoncolor{$color});
placemonster(\@r, \@pos, $celly, $cellx,
"$color dragon", 'D', $dragoncolor{$color})
for 1 .. (2 + int rand 3);
placemonster(\@r, \@pos, $celly, $cellx,
"baby $color dragon",
'D', $dragoncolor{$color})
for 1 .. (3 + int rand 4);
# TODO: place gold and gems and thematic stuff
#} elsif ($special eq 'another option') { # TODO
} else {
while ((rand(100) <= $fountainprob) and
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'fountain', $fountainchar,
$fountaincolor)) {
$fountcount++; $roomfountcount++;
if ($debug > 6) {
print color $fountaincolor;
print $fountainchar;
print color 'reset';
}
}}
while ((rand(100) <= $sinkprob) and
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'sink', $sinkchar, $sinkcolor)) {
$sinkcount++; $roomsinkcount++;
if ($debug > 6) {
print color $sinkcolor;
print $sinkchar;
print color 'reset';
}
}}
if ((rand(100) <= $altarprob) and
($altarcount < $maxaltars)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'altar', $altarchar, $altarcolor)) {
$altarcount++;
if ($debug > 6) {
print color $altarcolor;
print $altarchar;
print color 'reset';
}
if (rand(100) <= $priestprob) {
placemonster(\@r, \@pos, $celly, $cellx,
'aligned priest',
$priestchar, $priestcolor);
if ($debug > 6) {
print color $priestcolor;
print $priestchar;
print color 'reset';
}}
}}
if ((rand(100) <= $graveprob) and
($gravecount < $maxgraves)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'grave', $gravechar, $gravecolor)) {
$gravecount++;
if ($debug > 6) {
print color $gravecolor;
print $gravechar;
print color 'reset';
}
}}
# Step 5B: Terrain Features:
while ((rand(100) <= ($roompoolcount
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'pool', $poolchar,
$poolcolor)) {
$poolcount++; $roompoolcount++;
if ($debug > 6) {
print color $poolcolor;
print $poolchar;
print color 'reset';
}
}}
while ((rand(100) <= ($roomlavacount
? $morelavaprob
: $lavaprob))
and (lavacount < $maxlava)
and ($roomlavacount < $maxroomlava)
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'lava', $lavachar,
$lavacolor)) {
$lavacount++; $roomlavacount++;
if ($debug > 6) {
print color $lavacolor;
print $lavachar;
print color 'reset';
}
}}
my $roommonstcount = 0;
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
$roommonstcount++
if placemonster(\@r, \@pos, $celly, $cellx,
$mtype, $mchar, $mcolor);
if (rand(100)<= $mongroupprob) {
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
$roommonstcount++
if placemonster(\@r, \@pos, $celly, $cellx,
$mtype, $mchar, $mcolor);
}}}
}
# Step 5D: Place Objects
}}}
}
# Step Six: Place Corridors (including doors)
print "The pos array has " . @pos . "rows before corridors.\n"
if $debug > 9;
for my $celly ( 0 .. ((scalar @r) - 1)) {
for my $cellx ( 0 .. ((scalar @cellcol) - 1)) {
my $rect = $r[$celly][$cellx];
if (ref $$rect{roomgeom}) {
my $geom = $$rect{roomgeom};
print "Cell $celly,$cellx" if $debug > 10;
my @conn, %conn, $attempt;
my $cwanted = 1 + int rand $corridorfreq;
print " ($cwanted) " if $debug > 14;
while ($cwanted > scalar @conn) {
my ($xdir, $ydir, $origin) = (0, 0, +{});
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
print "*" if $debug > 11;
my $originok = 0;
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
print "<$ydir,$xdir>:" if $debug > 13;
$origindir =
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
# origin must be top or bottom
$$origin{y} = ($ydir > 0)
? $$geom{stopy}
: $$geom{starty};
$floorwidth = $$geom{width} - 2;
$$origin{x} = $$geom{startx} + 1
+ int rand $floorwidth;
} else {
# origin must be on the side
$$origin{x} = ($xdir > 0)
? $$geom{stopx}
: $$geom{startx};
$floorheight = $$geom{height} - 2;
$$origin{y} = $$geom{starty} + 1
+ int rand $$floorheight;
}
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# TODO: Do not allow origin at map edge.
if ((($celly == 0) and ($origindir eq 'vert')
and ($ydir <= 0))
or (($cellx == 0) and ($origindir eq 'horz')
and ($xdir <= 0))
) {
$originok = 0;
print "#" if $debug > 12;
} elsif (($origindir eq 'vert')
and ($celly == ((scalar @r) - 1))) {
$originok = 0 if $ydir >= 0;
} elsif (($origindir eq 'horz')
and ($cellx == ((scalar @cellcol) - 1))) {
$originok = 0 if $xdir >= 0;
}}
print "cell $celly,$cellx; o$origintry $origindir"
. "($$origin{y},$$origin{x}) $ydir,$xdir\n"
if $debug > 10;
if ($originok) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
} else {
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
}
my $x = $$origin{x};
my $y = $$origin{y};
my $connected = undef;
while (not $connected) {
my ($oldxdir, $oldydir) = ($xdir, $ydir);
print "." if $debug > 12;
if (rand(100) <= $corridortwist) {
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
my $loopcount = 0;
while ((($x + $xdir < 0) or
($x + $xdir > $maxfloorx + 1) or
($y + $ydir < 0) or
($y + $ydir > $maxfloory + 1) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
print "x$x,y$y,xdir$xdir,ydir$ydir,"
."oldxdir$oldxdir,oldydir$oldydir"
if ($loopcount == 999 and $debug > 10);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y + $ydir][$x]{char} eq $blankchar
#and $pos[$y + $ydir][$x]{terr} =~ /^blank/
) {
$pos[$y + $ydir][$x]{terr} = 'hall';
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x + $xdir]{char} eq $blankchar
#and $pos[$y + $ydir][$x]{terr} =~ /^blank/
) {
$pos[$y][$x + $xdir]{terr} = 'hall';
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
$x += $xdir;
$y += $ydir;
if (($y > $maxrows) or ($x > $maxcols)) {
warn "\n------------------------"
. "y$y,x$x,ydir$ydir,xdir$xdir\n"
if $debug > 4;
@pos = @save;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
}
if (($pos[$y][$x]{terr} eq 'wall') or
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
} else {
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
if (not $conn{$$rect{rect}}{$toroom}) {
# We've connected to a new room.
$conn{$$rect{rect}}{$toroom}++;
$conn{$toroom}{$$rect{rect}}++;
push @conn, $toroom;
$connected = 1;
print "N" if $debug > 12;
} else {
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe' if not ++$attempt %
$connectretry;
print "R" if $debug > 12;
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
$connected = 1;
push @conn, 'fail' if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} =~ /^rock/) {
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
print "\n" if $debug > 10;
}}
return @pos;
}
sub placeonfloor {
my ($rect, $grid) = @_;
my $miny = $$rect{roomgeom}{starty} + 1;
my $minx = $$rect{roomgeom}{startx} + 1;
my $maxy = $$rect{roomgeom}{stopy} - 1;
my $maxx = $$rect{roomgeom}{stopx} - 1;
print "[[$miny,$minx;$maxy,$maxx]]" if $debug > 8;
my $tried = 0;
while ($tried++ < 25) {
my $y = $miny + (int rand($maxy + 1 - $miny));
my $x = $minx + (int rand($maxx + 1 - $minx));
print "[$y,$x]" if $debug > 30;
if ($$grid[$y][$x]{terr} eq 'floor') {
return ($y, $x);
}}
return ($miny, $minx);
}
sub placefurniture {
my ($rects, $grid, $celly, $cellx, $terrain, $char, $colr, $y, $x) =
@_;
my @r = @$rects;
my $rect = $r[$celly][$cellx];
# use Data::Dumper; die Dumper(+{ rect => $rect, terr => $terrain,
char => $char });
if (ref $rect) {
if (ref $$rect{roomgeom}) {
($y, $x) = placeonfloor($rect, $grid) if not defined $x;
if ($$grid[$y][$x]{terr} eq 'floor') {
$$grid[$y][$x]{terr} = $terrain || 'ERROR';
$$grid[$y][$x]{char} = $char || $errorchar;
$$grid[$y][$x]{colr} = $colr || $errorcolor;
push @{$$grid[$y][$x]{furn}}, +{
y => $y,
x => $x,
type => $terrain,
};
if ($debug > 8) {
print "[$y,$x,$char]";
}
return [$y, $x];
} else {
print "<$$grid[$y][$x]{terr}>" if $debug > 30;
}
if ($debug > 8) {
print "N";
return;
}
} else {
print "X" if $debug > 8;
return;
}
} else {
print "-" if $debug > 8;
return;
}
}
sub placemonster {
my ($rects, $grid, $celly, $cellx, $type, $char, $colr) = @_;
my @r = @$rects;
my $rect = $r[$celly][$cellx];
if (ref $rect) {
if (ref $$rect{roomgeom}) {
my $tried = 0;
while ($tried++ < 15) {
# Only place one monster per tile:
my ($y, $x) = placeonfloor($rect, $grid);
print "[$y,$x]" if $debug > 30;
if (($$grid[$y][$x]{terr} eq 'floor') and
(not ref $$grid[$y][$x]{mons})){
$$grid[$y][$x]{mons} = +{
char => $char || $errorchar,
type => $type || 'MONSTER',
colr => $colr || 'reset',
};
if ($debug > 8) {
print "[$y,$x,$char]";
}
return [$y, $x];
} else {
print "<$$grid[$y][$x]{terr}>" if $debug > 30;
}
}
if ($debug > 8) {
print "N";
return;
}
} else {
print "X" if $debug > 8;
return;
}
} else {
print "-" if $debug > 8;
return;
}
}
sub rectcolor {
my ($n) = @_;
my @clr = ('white on_black', 'white on_blue',
'white on_red', 'white on_cyan',
'white on_green', 'white on_magenta',
'black on_white', 'black on_yellow');
while (((scalar @clr) > 1)
and (not ((scalar @cellcol) % (scalar @clr)))
) {
#warn "cell columns: " . scalar @cellcol;
#warn "colors is a factor: " . scalar @clr;
pop @clr;
}
#use Data::Dumper; print Dumper(\@clr); exit 0;
return $clr[$n % (scalar @clr)];
}
sub printlevel {
my (%a) = @_;
my @p = @{$a{level}};
print color 'reset';
print "\n";
if ($a{title}) {
my $spaces = int(($maxcols - (length $a{title})) / 2);
print " " x $spaces;
print "$a{title}\n\n";
}
for my $row (@p) {
for my $cell (@$row) {
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
#} elsif ($$cell{mons}{objs}) { # TODO
} else {
if ($a{debug} or ($debug > 3)) {
print color rectcolor($$cell{rect});
} else {
print color $$cell{colr} if $$cell{colr};
}
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
# -*- cperl -*-
# This is a Perl program that generates a proposed new type
# of NetHack level, consisting of a denser packing of rooms
# and corridors than the traditional one. This is strictly
# experimental, and of course this Perl code will not
# integrate into NetHack, so in order to be used it would
# need to be reimplemented in C and integrated into
# NetHack's existing level-generation code.
# If implemented, these types of levels could be used in
# custom dungeon content, in special levels (e.g., quest
# filler levels for proposed new roles), and potentially
# in Gehennom to replace some of the maze levels.
# Note that these levels should NOT be used very early in
# the dungeons, because they may contain disconnected areas
# that can only be reached by digging or teleport, as well
# as water and/or lava that may need to be traversed in some
# cases. Also, the special rooms contain monsters that a
# pre-quest, pre-castle character should not have to face.
# In other words, these are strictly late-game levels.
# Don't worry if the choices of monsters seem odd. Except
# for special rooms, this script does not attempt realistic
# monster generation, because the intention is that the
# existing monster generation code be used. So while this
# script does pepper the levels with random monsters, that's
# just so they don't look totally bare.
# Other than that, there are still a few bugs to work out
# (e.g., doors on the corners of rooms shouldn't happen),
# but I think it's reached the point where it's worth
# soliciting feedback...
# If the idea of new kinds of levels to mix in with the
# mazes in Gehennom interests you, please run this Perl
# script a few times and let me know what you think.
# Specific suggestions are welcome.
my %arg = @ARGV;
my $debug = $arg{debug} || 3;
my $maxrows = $arg{maxrows} || 24;
my $maxcols = $arg{maxcols} || 65 + int rand(4);
my $minroomwidth = $arg{minroomwidth} || 2 + int rand(3);
my $minroomheight = $arg{minroomheight} || 2 + int rand(2);
my $minrectwidth = $minroomwidth + 2 + int rand(3);
my $minrectheight = $minroomheight + 2;# + int rand(1);
print "Min rect: $minrectwidth x $minrectheight"
. "; min room: $minroomwidth x $minroomheight\n" if $debug;
my $maxrectwidth = $arg{maxrectwidth} || 11 + int rand(5);
my $maxrectheight = $arg{maxrectheight} || 6 + int rand(3);
my $roomprob = $arg{roomprob} || 90;
my $secretprob = $arg{secretprob} || 30;
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $floorchar = $arg{floorchar} || '.';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $nwcornerchar = $arg{nwcornerchar} || '-';
my $necornerchar = $arg{necornerchar} || '-';
my $swcornerchar = $arg{swcornerchar} || '-';
my $secornerchar = $arg{secornerchar} || '-';
my $errorchar = $arg{errorchar} || 'E';
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
my $wallcolor = $arg{wallcolor} || 'white on_black';
my $floorcolor = $arg{floorcolor} || 'reset';
my $doorcolor = $arg{doorcolor} || 'yellow on_black';
my $sdoorcolor = $arg{sdoorcolor} || $wallcolor;
my $corridorcolor = $arg{corridorcolor} || 'reset';
my $corridorfreq = $arg{corridorfreq} || 2 + int rand 2;
my $corridortwist = $arg{corridortwist} || 12;
my $connectretry = $arg{connectretry} || 3;
my $mergethreshold= $arg{mergethreshold}|| 2;
my $mergeprob = $arg{mergeprob} || 45;
my $fountainprob = $arg{fountainprob} || 7;
my $maxfountains = $arg{maxfountains} || 8;
my $maxroomfounts = $arg{maxroomfounts} || 4;
my $staircolor = $arg{staircolor} || 'bold white';
my $upstaircolor = $arg{upstaircolor} || $staircolor;
my $downstaircolor= $arg{downstaircolor}|| $staircolor;
my $fountainchar = $arg{fountainchar} || '{';
my $fountaincolor = $arg{fountaincolor} || 'bold blue';
my $sinkprob = $arg{sinkprob} || 5;
my $maxsinks = $arg{maxsinks} || 6;
my $maxroomsinks = $arg{maxroomsinks} || 1;
my $sinkchar = $arg{sinkchar} || '#';
my $sinkcolor = $arg{sinkcolor} || 'bold cyan';
my $altarprob = $arg{altarprob} || 3;
my $maxaltars = $arg{maxaltars} || 2;
my $priestprob = $arg{priestprob} || 30;
my $altarchar = $arg{altarchar} || '_';
my $altarcolor = $arg{altarcolor} || 'bold yellow';
my $priestchar = $arg{priestchar} || '@';
my $priestcolor = $arg{priestcolor} || 'bold white';
my $graveprob = $arg{graveprob} || 5;
my $maxgraves = $arg{maxgraves} || 3;
my $gravechar = $arg{gravechar} || '|';
my $gravecolor = $arg{gravecolor} || 'bold white on_black';
my $poolprob = $arg{poolprob} || 7;
my $morepoolprob = $arg{morepoolprob} || 65;
my $maxpools = $arg{maxpools} || 15;
my $maxroompools = $arg{maxroompools} || 9;
my $poolchar = $arg{poolchar} || '}';
my $poolcolor = $arg{poolcolor} || 'bold cyan on_blue';
my $lavaprob = $arg{lavaprob} || 12;
my $morelavaprob = $arg{morelavaprob} || 85;
my $maxlava = $arg{maxlava} || 9;
my $maxroomlava = $arg{maxroomlava} || 9;
my $lavachar = $arg{lavachar} || '}';
my $lavacolor = $arg{lavacolor} || 'bold red';
my $specialprob = $arg{specialprob} || 7;
my $statuechar = $arg{statuechar} || "`";
my $statuecolor = $arg{statuecolor} || 'reset';
my $statuespacing = $arg{statuespacing} || undef;
my $monsterprob = $arg{monsterprob} || 45;
my $mongroupprob = $arg{mongroupprob} || 5;
my $moremonstprob = $arg{moremonstprob} || 75;
my $maxgroupsize = $arg{maxgroupsize} || 9;
my $maxroommonst = $arg{maxroommonst} || 11;
my @randmonst = (
# This list is not intended to accurately
# reflect what would actually happen in
# the game. It's just a sampling so the
# levels can look approximately normal.
# (The proposed dense-room-and-corridor
# levels, if implemented, would use the
# existing random monster generation code.)
['water demon', '&', 'blue'],
['horned devil', '&', 'bold red'],
['succubus', '&', 'reset'],
['incubus', '&', 'reset'],
['barbed devil', '&', 'red'],
['vrock', '&', 'red'],
['hezrou', '&', 'red'],
['bone devil', '&', 'white'],
['ice devil', '&', 'bold white'],
['nalfeshnee', '&', 'red'],
['pit fiend', '&', 'red'],
['balrog', '&', 'red'],
['fire ant', 'a', 'red'],
['hell hound', 'd', 'red'],
['tiger', 'f', 'bold yellow'],
['gremlin', 'g', 'green'],
['gargoyle', 'g', 'yellow'],
['winged gargoyle', 'g', 'magenta'],
['mind flayer', 'h', 'bold magenta'],
['ochre jelly', 'j', 'yellow'],
['giant mimic', 'm', 'magenta'],
['mountain nymph', 'n', 'yellow'],
['Uruk-hai', 'o', 'bold black'],
['orc-captain', 'o', 'magenta'],
['wumpus', 'q', 'cyan'],
['titanothere', 'q', 'reset'],
['mastodon', 'q', 'bold black'],
['trapper', 't', 'green'],
['purple worm', 'w', 'bold magenta'],
['xan', 'x', 'red'],
['zruty', 'z', 'yellow'],
['vampire bat', 'B', 'bold black'],
['stalker', 'E', 'bold white'],
['air elemental', 'E', 'bold cyan'],
['fire elemental', 'E', 'bold yellow'],
['earth elemental', 'E', 'yellow'],
['water elemental', 'E', 'bold blue'],
['shrieker', 'F', 'bold magenta'],
['titan', 'H', 'bold magenta'],
['storm giant', 'H', 'bold blue'],
['jabberwock', 'J', 'bold red'],
['arch-lich', 'L', 'bold magenta'],
['demilich', 'L', 'red'],
['golden naga', 'N', 'bold yellow'],
['ogre king', 'O', 'magenta'],
['green slime', 'P', 'bold green'],
['disenchanter', 'R', 'blue'],
['Olog-hai', 'T', 'bold magenta'],
['umber hulk', 'U', 'yellow'],
['wraith', 'W', 'bold black'],
['xorn', 'X', 'yellow'],
['sasquatch', 'Y', 'reset'],
['iron golem', "'", 'cyan'],
['ghost', ' ', 'bold black'],
);
$|=1;
while ($maxrectwidth < $minrectwidth + 2) {
warn "Max rect width ("
. $maxrectwidth . ") too small; adjusting.";
++$maxrectwidth;
}
while ($maxrectheight < $minrectheight + 1) {
warn "Max rect height ("
. $maxrectheight. ") too small; adjusting.";
++$maxrectheight;
}
die "Not enough columns to fit a max-size rect."
if $maxcols < $maxrectwidth;
die "Not enough rows to fit a max-size rect."
if $maxrows < $maxrectheight;
use Term::ANSIColor;
# First, lay out a basic grid of rectangles:
my @cellcol;
my @rect; {
my $cellx = 0;
my $x = 0;
while ($x + $maxrectwidth <= $maxcols) {
my $width = $minrectwidth
+ int rand($maxrectwidth - $minrectwidth);
my $startx = $x;
$x += $width;
my $endx = $x;
$cellcol[$cellx++] = +{
cellx => $cellx,
startx => $startx,
stopx => $startx + $width,
};
$x++; # Don't overlap by one.
}
my ($y, $celly, $rect) = (0, 0, 0);
while ($y + $maxrectheight <= $maxrows) {
my $height = $minrectheight
+ int rand($maxrectheight - $minrectheight);
my $starty = $y;
$y += $height;
my $endy = $y;
$y++;
my ($x, $cellx) = (0, 0);
foreach my $cellcol (@cellcol) {
my $width = $minrectwidth
+ int rand($maxrectwidth - $minrectwidth);
my $startx = $x;
$x += $width;
my $endx = $x;
$rect[$celly][$cellx] = +{
rect => ++$rect,
celly => $celly,
starty => $starty,
stopy => $starty + $height,
maxy => $maxrows,
maxx => $maxcols,
miny => 0,
minx => 0,
map { $_ =>
${$cellcol[$cellx]}{$_}
} qw(cellx startx stopx),
};
$cellx++;
}
$celly++;
}
}
if ($debug > 4) {
my @stageone = buildlevel(@rect);
#use Data::Dumper; print Dumper(\@rect);
printlevel(level => \@stageone,
title => "Stage One",
debug => $debug,
);
}
print "Minimum rect dimensions: $minrectheight,$minrectwidth\n"
if $debug > 4;
# That's a start, but it's a bit too regular. The cells in
# each row are the same height and line up at the top and
# bottom, and the cells in each column are the same width
# and line up at left and right. To fix this, we want to
# push some of their borders around a bit.
# The trick is deciding which borders to push in a way that
# doesn't lead to overlapping. If a cell is enlarged
# southward, for example, then the cell to the southwest
# cannot be enlarged eastward: its eastern side must be
# capped at a maximum that leaves it not overlapping.
# Similarly, the cell to the southeast will have its
# western edge limited.
# To support this, we introduce four new fields to each
# cell: minx, maxx, miny, maxy. They will all start at
# undef, meaning the cell is limited only by its immediate
# neighbors (vertically and horizontally). When a border
# is pushed, these limits will be checked first (to see
# if the push is allowed) and then adjusted after (to
# prevent subsequent pushes from overlapping).
# There are scalar @cellcol columns of cells, numbered from
# 0 to ((scalar @cellcol) - 1) and scalar @rect rows of
# cells, numberd from 0 to ((scalar @rect) - 1). In order
# to prevents systematic bias, we want to consider these
# borders in random order. To do that, we need a list:
my @border = (
# Vertical borders:
(map {
my $y = $_; # y coord of second/bottom cell
map {
my $x = $_; # x coord of both cells
+{
direction => 'y',
cellone => [ $y - 1, $x ],
celltwo => [ $y, $x ],
}
} 0 .. ((scalar @cellcol) - 1);
} 1 .. ((scalar @rect) - 1)),
# Horizontal borders:
(map {
my $y = $_; # y coord of both cells
map {
my $x = $_; # x coord of second/right cell
+{
direction => 'x',
cellone => [ $y, $x - 1 ],
celltwo => [ $y, $x ],
}
} 1 .. ((scalar @cellcol) - 1);
} 0 .. ((scalar @rect) - 1),
));
# Put that list in a random order:
@border = map {
$$_[0]
} sort {
$$a[1] <=> $$b[1]
} map {
[ $_ => rand(1087) ]
} @border;
my @maybemerge;
# Now we got through the list of borders...
for my $border (@border) {
my $oney = $$border{cellone}[0]; # This
my $onex = $$border{cellone}[1]; # saves
my $twoy = $$border{celltwo}[0]; # confusion
my $twox = $$border{celltwo}[1]; # below.
print "Considering border between cells $oney,$onex"
. " and $twoy,$twox\n" if $debug > 6;
if ($$border{direction} eq 'y') {
# The two cells have different y coords, same x.
if (rand(100)>= 50) {
# Try to enlarge the first cell (shrink the second).
print " Want to grow south.\n" if $debug > 7;
# First off, the second cell can't be shrunk to less
# than the minimum height:
my $twocurrentheight
= $rect[$twoy][$twox]{stopy}
- $rect[$twoy][$twox]{starty};
my $maxshrink = $twocurrentheight - $minrectheight;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $maxy = $rect[$oney][$onex]{stopy} + $maxshrink;
if ($rect[$oney][$onex]{maxy} > $maxy) {
$rect[$oney][$onex]{maxy} = $maxy;
} else {
$maxy = $rect[$oney][$onex]{maxy};
}
my $maxgrow = $maxy - $rect[$oney][$onex]{stopy};
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print " Growing cell $oney,$onex south by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopy} += $grow;
$rect[$twoy][$twox]{starty} += $grow;
push @maybemerge, $border
if abs($grow) >= $mergethreshold;
# Limit nearby cells so they won't overlap:
if (($twox >= 1)
and ($rect[$twoy][$twox - 1]{maxx}
>= $rect[$oney][$onex]{startx})) {
$rect[$twoy][$twox - 1]{maxx} =
$rect[$oney][$onex]{startx} - 1;
}
if (($twox + 1 < (scalar @cellcol))
and ($rect[$twoy][$twox + 1]{minx}
<= $rect[$oney][$onex]{startx})) {
$rect[$twoy][$twox + 1]{minx} =
$rect[$oney][$onex]{startx} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $oney,$onex South",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $oney,$onex south.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
max => $maxy,
cur => $twocurrentheight,
});
}
} else {
# Try to enlarge the second cell (shrink the first).
print " Want to grow north.\n" if $debug > 7;
# First off, the first cell can't be shrunk to less
# than the minimum height:
my $onecurrentheight
= $rect[$oney][$onex]{stopy}
- $rect[$oney][$onex]{starty};
my $maxshrink = $onecurrentheight - $minrectheight;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $miny = $rect[$twoy][$twox]{starty} - $maxshrink;
if ($rect[$twoy][$twox]{miny} < $miny) {
$rect[$twoy][$twox]{miny} = $miny;
} else {
$miny = $rect[$twoy][$twox]{miny};
}
my $maxgrow = $rect[$twoy][$twox]{starty} - $miny;
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print " Growing cell $twoy,$twox north by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopy} -= $grow;
$rect[$twoy][$twox]{starty} -= $grow;
# Limit nearby cells so they won't overlap:
if (($onex >= 1)
and ($rect[$oney][$onex - 1]{maxx}
>= $rect[$twoy][$twox]{startx})) {
$rect[$oney][$onex - 1]{maxx} =
$rect[$twoy][$twox]{startx} - 1;
}
if (($onex + 1 < (scalar @cellcol))
and ($rect[$oney][$onex + 1]{minx}
<= $rect[$twoy][$twox]{startx})) {
$rect[$oney][$onex + 1]{maxy} =
$rect[$twoy][$twox]{startx} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $twoy,$twox North",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $twoy,$twox north.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
min => $miny,
cur => $onecurrentheight,
});
}
}
} elsif ($$border{direction} eq 'x') {
# The two cells have different x coords, same y.
if (rand(100)>= 50) {
# Try to enlarge the first cell (shrink the second).
print " Want to grow east.\n" if $debug > 7;
# First off, the second cell can't be shrunk to less
# than the minimum width:
my $twocurrentwidth
= $rect[$twoy][$twox]{stopx}
- $rect[$twoy][$twox]{startx};
my $maxshrink = $twocurrentwidth - $minrectwidth;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $maxx = $rect[$oney][$onex]{stopx} + $maxshrink;
# TODO: Not entirely sure but what catycorner rects
# should also be checked.
if ($rect[$oney][$onex]{maxx} > $maxx) {
$rect[$oney][$onex]{maxx} = $maxx;
} else {
$maxx = $rect[$oney][$onex]{maxx};
}
my $maxgrow = $maxx - $rect[$oney][$onex]{stopx};
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print " Growing cell $oney,$onex east by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopx} += $grow;
$rect[$twoy][$twox]{startx} += $grow;
push @maybemerge, $border
if abs($grow) >= $mergethreshold;
# Limit nearby cells so they won't overlap:
if (($twoy >= 1)
and ($rect[$twoy - 1][$twox]{maxy}
>= $rect[$oney][$onex]{starty})) {
$rect[$twoy - 1][$twox]{maxy} =
$rect[$oney][$onex]{starty} - 1;
}
if (($twoy + 1 < (scalar @rect))
and ($rect[$twoy + 1][$twox]{miny}
<= $rect[$oney][$onex]{stopy})) {
$rect[$twoy + 1][$twox]{miny} =
$rect[$oney][$onex]{stopy} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $oney,$onex East",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $oney,$onex east.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
max => $maxx,
cur => $twocurrentwidth,
});
}
} else {
# Try to enlarge the first cell (shrink the second).
print " Want to grow west.\n" if $debug > 7;
# First off, the first cell can't be shrunk to less
# than the minimum width:
my $onecurrentwidth
= $rect[$oney][$onex]{stopx}
- $rect[$oney][$onex]{startx};
my $maxshrink = $onecurrentwidth - $minrectwidth;
print " Maximum shrink calculated at $maxshrink.\n"
if $debug > 9;
my $minx = $rect[$twoy][$twox]{stopx} - $maxshrink;
# TODO: Not entirely sure but what catycorner rects
# should also be checked.
if ($rect[$twoy][$twox]{minx} < $minx) {
$rect[$twoy][$twox]{minx} = $minx;
} else {
$minx = $rect[$twoy][$twox]{minx};
}
my $maxgrow = $rect[$twoy][$twox]{startx} - $minx;
print " Maximum growth calculated at $maxgrow.\n"
if $debug > 8;
if ($maxgrow > 0) {
my $grow = int rand($maxgrow) + 1;
print "Growing cell $twoy,$twox west by $grow.\n"
if $debug > 4;
$rect[$oney][$onex]{stopx} -= $grow;
$rect[$twoy][$twox]{startx} -= $grow;
# Limit nearby cells so they won't overlap:
if (($oney >= 1)
and ($rect[$oney - 1][$onex]{maxy}
>= $rect[$twoy][$twox]{starty})) {
$rect[$oney - 1][$onex]{maxy}
= $rect[$twoy][$twox]{starty} - 1;
}
if (($oney + 1 < (scalar @rect))
and ($rect[$oney + 1][$onex]{miny}
<= $rect[$twoy][$twox]{starty})) {
$rect[$oney + 1][$onex]{miny}
= $rect[$twoy][$twox]{starty} + 1;
}
if ($debug > 8) {
my @stage = buildlevel(@rect);
printlevel(level => \@stage,
title => "Growing Cell $twoy,$twox West",
debug => $debug);
}
} elsif ($debug > 5) {
print " Cannot grow cell $twoy,$twox west.\n";
use Data::Dumper;
print Dumper(+{
one => $rect[$oney][$onex],
two => $rect[$twoy][$twox],
min => $minx,
cur => $onecurrentwidth,
});
}}
} else {
die "Impossible border direction: '$$border{direction}'";
}
}
if ($debug > 4) {
my @stagetwo = buildlevel(@rect);
printlevel(level => \@stagetwo,
title => "Stage Two",
debug => $debug);
}
# Combine a few adjacent rectangles if possible:
# Start by putting the list in a new random order:
print "There are " . @maybemerge
. " cell pairs to consider merging.\n"
if $debug > 2;
@maybemerge = map {
$$_[0]
} sort {
$$a[1] <=> $$b[1]
} map {
[ $_ => rand(1087) ]
} @maybemerge;
for my $pair (@maybemerge) {
my $oney = $$pair{cellone}[0]; # This
my $onex = $$pair{cellone}[1]; # saves
my $twoy = $$pair{celltwo}[0]; # confusion
my $twox = $$pair{celltwo}[1]; # below.
my $rone = $rect[$oney][$onex];
my $rtwo = $rect[$twoy][$twox];
if ((ref $rone) and (ref $rtwo)) {
print "Considering merging cells $oney,$onex"
. " and $twoy,$twox" if $debug > 6;
if (rand(100)<= $mergeprob) {
print ", decided to try.\n" if $debug > 6;
if ($$border{direction} eq 'y') {
# The two cells have different y coords, same x.
my $newstartx = $$rone{startx};
my $newstopx = $$rone{stopx};
$newstartx = $$rtwo{startx}
if $$rtwo{startx} > $newstartx;
$newstopx = $$rtwo{stopx}
if $$rtwo{stopx} < $newstopx;
if ($newstopx - $newstartx >= $minrectwidth) {
my $newstarty = $$rone{starty};
my $newstopy = $$rtwo{starty};
$rect[$oney][$onex] = +{
rect => $$rone{rect},
celly => $oney,
twoy => $twoy,
cellx => $onex,
starty => $newstarty,
stopy => $newstopy,
startx => $newstartx,
stopx => $newstartx,
merged => 'y',
};
push @purged, $rect[$twoy][$twox];
$rect[$twoy][$twox] = undef;
print "Merged vertically: $newstarty,$newstartx"
. " $newstopy,$newstopx.\n" if $debug >= 3;
} else {
print "New rect would not be wide enough "
. "($newstopx - $newstartx < $minrectwidth).\n"
if $debug > 6;
}
} else {
# The two cells have different x coords, same y.
my $newstarty = $$rone{starty};
my $newstopy = $$rone{stopy};
$newstarty = $$rtwo{starty}
if $$rtwo{starty} > $newstarty;
$newstopy = $$rtwo{stopy}
if $$rtwo{stopy} < $newstopy;
if ($newstopy - $newstarty >= $minrectheight) {
my $newstartx = $$rone{startx};
my $newstopx = $$rtwo{stopx};
$rect[$oney][$onex] = +{
rect => $$rone{rect},
celly => $oney,
cellx => $onex,
twox => $twox,
starty => $newstarty,
stopy => $newstopy,
startx => $newstartx,
stopx => $newstopx,
merged => 'x',
};
push @purged, $rect[$twoy][$twox];
$rect[$twoy][$twox] = undef;
print "Merged horizontally: $newstarty,$newstartx"
. " $newstopy,$newstopx.\n" if $debug >= 3;
} else {
print "New rect would not be tall enough "
. "($newstopy - $newstarty < $minrectheight.)\n"
if $debug > 6;
}
}
} else {
print ", decided against it.\n" if $debug > 6;
}
}}
use Data::Dumper; print Dumper(+{ purged => \@purged })
if $debug > 7;
my @finalstage = buildlevel(@rect);
printlevel(level => \@finalstage);
sub buildlevel {
my @r = @_;
my ($maxfloorx, $maxfloory) = (0,0);
my @pos = map { # Initialize to blank:
[ map { +{ char => $blankchar,
terr => 'rock (by default)',
colr => 'reset',
furn => [],
objs => [],
mons => undef,
rect => undef,
room => undef,
} } 1 .. $maxcols ],
} 1 .. $maxrows;
print "The pos array has " . @pos . "rows after init.\n"
if $debug > 9;
for my $celly ( 0 .. ((scalar @r) - 1)) {
for my $cellx ( 0 .. ((scalar @cellcol) - 1)) {
my $rect = $r[$celly][$cellx];
if (ref $rect) {
my $rdig = $$rect{rect} % 10;
warn "Mismatch on celly" if $$rect{celly} ne $celly;
warn "Mismatch on cellx" if $$rect{cellx} ne $cellx;
# Step One: Assign Rectangle
for my $y ($$rect{starty} .. $$rect{stopy}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
$pos[$y][$x]{rect} = $$rect{rect};
$pos[$y][$x]{char} = $rdig if $debug > 12;
}
}
if (rand(100)<=$roomprob) {
# Step Two: Calculate Room Size and Position:
my $rectwidth = $$rect{stopx} - $$rect{startx};
my $rectheight = $$rect{stopy} - $$rect{starty};
# Leave room for at least one corridor tile:
my $maxroomwidth = $rectwidth - 1
- int rand rand ($rectwidth - $minroomwidth);
my $maxroomheight = $rectheight - 1
- int rand rand ($rectheight - $minroomheight);
my $roomwidth = $maxroomwidth
- int rand int rand ($maxroomwidth - $minroomwidth);
my $roomheight = $maxroomheight
- int rand int rand ($maxroomheight - $minroomheight);
my $xslop = $rectwidth - $roomwidth;
my $yslop = $rectheight - $roomheight;
my $roomstartx = $$rect{startx} + int rand $xslop;
my $roomstarty = $$rect{starty} + int rand $yslop;
my $roomstopx = $roomstartx + $roomwidth;
my $roomstopy = $roomstarty + $roomheight;
$r[$celly][$cellx]{roomgeom} = +{
startx => $roomstartx,
starty => $roomstarty,
stopx => $roomstopx,
stopy => $roomstopy,
width => $roomwidth,
height => $roomheight,
};
# Step Three: Place Floor
my $fc = ($debug > 7) ? ($$rect{rect}%10) : $floorchar;
for my $y (($roomstarty + 1) .. ($roomstopy - 1)) {
for my $x (($roomstartx + 1) .. $roomstopx - 1) {
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{char} = $fc;
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{room} = $$rect{rect};
$maxfloory = $y if $y > $maxfloory;
$maxfloorx = $x if $x > $maxfloorx;
}}
# Step Four: Place Walls
for my $y ($roomstarty .. $roomstopy) {
for my $x ($roomstartx, $roomstopx) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} = $$rect{rect};
}}
for my $y ($roomstarty, $roomstopy) {
for my $x ($roomstartx .. $roomstopx) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} = $$rect{rect};
}}
$pos[$roomstarty][$roomstartx]{char} = $nwcornerchar;
$pos[$roomstarty][$roomstopx]{char} = $necornerchar;
$pos[$roomstopy][$roomstartx]{char} = $swcornerchar;
$pos[$roomstopy][$roomstopx]{char} = $secornerchar;
$pos[$roomstarty][$roomstartx]{crnr} = 1;
$pos[$roomstarty][$roomstopx]{crnr} = 1;
$pos[$roomstopy][$roomstartx]{crnr} = 1;
$pos[$roomstopy][$roomstopx]{crnr} = 1;
} else {
$r[$celly][$cellx]{roomgeom} = undef;
}}
}}
my @roomcell = sort { $$a[2] <=> $$b[2] } map {
my $celly = $_;
map {
my $cellx = $_;
[$celly, $cellx, rand(739)];
} 0 .. ((scalar @cellcol) - 1);
} 0 .. ((scalar @r) - 1);
# Step Five: Place Contents:
{
my ($didup, $diddown) = (0, 0);
my ($fountcount, $sinkcount, $altarcount, $gravecount,
$poolcount, $lavacount) = (0, 0, 0, 0, 0, 0);
for my $cell (@roomcell) {
my ($celly, $cellx) = @$cell;
my $rect = $r[$celly][$cellx];
if (ref $rect) {
print " R$$rect{rect}" if $debug > 13;
my ($roomfountcount, $roomsinkcount,
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
# Step 5A: Place Furniture
my $special;
if (not $didup) {
$didup = placefurniture(\@r, \@pos, $celly, $cellx,
'stairs', '<', $upstaircolor);
if ($didup and ($debug > 6)) {
print color $staircolor;
print '<';
print color 'reset';
}
} elsif (not $diddown) {
$diddown = placefurniture(\@r, \@pos, $celly, $cellx,
'stairs', '>', $downstaircolor);
if ($diddown and ($debug > 6)) {
print color $staircolor;
print '>';
print color 'reset';
}
} else {
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
if (rand(100)<=60) {
$special = 'dragon lair';
} # TODO: more special-room options
}}
if ($special eq 'statue hall') {
my @bordertile;
my $statuecount;
push @bordertile, $_ for map {
my $x = $_;
[$$rect{roomgeom}{starty} + 1, $x]
} ($$rect{roomgeom}{startx} + 1)
.. ($$rect{roomgeom}{stopx} - 1);
push @bordertile, $_ for map {
my $y = $_;
[$y, $$rect{roomgeom}{stopx} - 1]
} ($$rect{roomgeom}{starty} + 2)
.. ($$rect{roomgeom}{stopy} - 2);
push @bordertile, $_ for map {
my $x = $_;
[$$rect{roomgeom}{stopy} - 1, $x]
} reverse (($$rect{roomgeom}{startx} + 1)
.. ($$rect{roomgeom}{stopx} - 1));
push @bordertile, $_ for map {
my $y = $_;
[$y, $$rect{roomgeom}{startx} + 1]
} reverse (($$rect{roomgeom}{starty} + 2)
.. ($$rect{roomgeom}{stopy} - 2));
my $spacing = (defined $statuespacing)
? $statuespacing : ((int rand(5)) ? 1 : rand(3));
while (scalar @bordertile) {
my $tile = shift @bordertile;
placefurniture(\@r, \@pos, $celly, $cellx,
'statue', $statuechar,
$statuecolor, @$tile);
for (1 .. $spacing) {
shift @bordertile if scalar @bordertile;
}}
# TODO: also place some traps in the room.
} elsif ($special eq 'dragon lair') {
my %dragoncolor = (black => 'bold black',
red => 'bold red',
blue => 'blue',
gray => 'white');
my @color = keys %dragoncolor;
my $color = $color[rand @color];
placemonster(\@r, \@pos, $celly, $cellx,
"great $color dragon",
'D', $dragoncolor{$color});
placemonster(\@r, \@pos, $celly, $cellx,
"$color dragon", 'D', $dragoncolor{$color})
for 1 .. (2 + int rand 3);
placemonster(\@r, \@pos, $celly, $cellx,
"baby $color dragon",
'D', $dragoncolor{$color})
for 1 .. (3 + int rand 4);
# TODO: place gold and gems and thematic stuff
#} elsif ($special eq 'another option') { # TODO
} else {
while ((rand(100) <= $fountainprob) and
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'fountain', $fountainchar,
$fountaincolor)) {
$fountcount++; $roomfountcount++;
if ($debug > 6) {
print color $fountaincolor;
print $fountainchar;
print color 'reset';
}
}}
while ((rand(100) <= $sinkprob) and
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'sink', $sinkchar, $sinkcolor)) {
$sinkcount++; $roomsinkcount++;
if ($debug > 6) {
print color $sinkcolor;
print $sinkchar;
print color 'reset';
}
}}
if ((rand(100) <= $altarprob) and
($altarcount < $maxaltars)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'altar', $altarchar, $altarcolor)) {
$altarcount++;
if ($debug > 6) {
print color $altarcolor;
print $altarchar;
print color 'reset';
}
if (rand(100) <= $priestprob) {
placemonster(\@r, \@pos, $celly, $cellx,
'aligned priest',
$priestchar, $priestcolor);
if ($debug > 6) {
print color $priestcolor;
print $priestchar;
print color 'reset';
}}
}}
if ((rand(100) <= $graveprob) and
($gravecount < $maxgraves)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'grave', $gravechar, $gravecolor)) {
$gravecount++;
if ($debug > 6) {
print color $gravecolor;
print $gravechar;
print color 'reset';
}
}}
# Step 5B: Terrain Features:
while ((rand(100) <= ($roompoolcount
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'pool', $poolchar,
$poolcolor)) {
$poolcount++; $roompoolcount++;
if ($debug > 6) {
print color $poolcolor;
print $poolchar;
print color 'reset';
}
}}
while ((rand(100) <= ($roomlavacount
? $morelavaprob
: $lavaprob))
and (lavacount < $maxlava)
and ($roomlavacount < $maxroomlava)
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
if (placefurniture(\@r, \@pos, $celly, $cellx,
'lava', $lavachar,
$lavacolor)) {
$lavacount++; $roomlavacount++;
if ($debug > 6) {
print color $lavacolor;
print $lavachar;
print color 'reset';
}
}}
my $roommonstcount = 0;
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
$roommonstcount++
if placemonster(\@r, \@pos, $celly, $cellx,
$mtype, $mchar, $mcolor);
if (rand(100)<= $mongroupprob) {
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
$roommonstcount++
if placemonster(\@r, \@pos, $celly, $cellx,
$mtype, $mchar, $mcolor);
}}}
}
# Step 5D: Place Objects
}}}
}
# Step Six: Place Corridors (including doors)
print "The pos array has " . @pos . "rows before corridors.\n"
if $debug > 9;
for my $celly ( 0 .. ((scalar @r) - 1)) {
for my $cellx ( 0 .. ((scalar @cellcol) - 1)) {
my $rect = $r[$celly][$cellx];
if (ref $$rect{roomgeom}) {
my $geom = $$rect{roomgeom};
print "Cell $celly,$cellx" if $debug > 10;
my @conn, %conn, $attempt;
my $cwanted = 1 + int rand $corridorfreq;
print " ($cwanted) " if $debug > 14;
while ($cwanted > scalar @conn) {
my ($xdir, $ydir, $origin) = (0, 0, +{});
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
print "*" if $debug > 11;
my $originok = 0;
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
print "<$ydir,$xdir>:" if $debug > 13;
$origindir =
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
# origin must be top or bottom
$$origin{y} = ($ydir > 0)
? $$geom{stopy}
: $$geom{starty};
$floorwidth = $$geom{width} - 2;
$$origin{x} = $$geom{startx} + 1
+ int rand $floorwidth;
} else {
# origin must be on the side
$$origin{x} = ($xdir > 0)
? $$geom{stopx}
: $$geom{startx};
$floorheight = $$geom{height} - 2;
$$origin{y} = $$geom{starty} + 1
+ int rand $$floorheight;
}
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# TODO: Do not allow origin at map edge.
if ((($celly == 0) and ($origindir eq 'vert')
and ($ydir <= 0))
or (($cellx == 0) and ($origindir eq 'horz')
and ($xdir <= 0))
) {
$originok = 0;
print "#" if $debug > 12;
} elsif (($origindir eq 'vert')
and ($celly == ((scalar @r) - 1))) {
$originok = 0 if $ydir >= 0;
} elsif (($origindir eq 'horz')
and ($cellx == ((scalar @cellcol) - 1))) {
$originok = 0 if $xdir >= 0;
}}
print "cell $celly,$cellx; o$origintry $origindir"
. "($$origin{y},$$origin{x}) $ydir,$xdir\n"
if $debug > 10;
if ($originok) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
} else {
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
}
my $x = $$origin{x};
my $y = $$origin{y};
my $connected = undef;
while (not $connected) {
my ($oldxdir, $oldydir) = ($xdir, $ydir);
print "." if $debug > 12;
if (rand(100) <= $corridortwist) {
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
my $loopcount = 0;
while ((($x + $xdir < 0) or
($x + $xdir > $maxfloorx + 1) or
($y + $ydir < 0) or
($y + $ydir > $maxfloory + 1) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
print "x$x,y$y,xdir$xdir,ydir$ydir,"
."oldxdir$oldxdir,oldydir$oldydir"
if ($loopcount == 999 and $debug > 10);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y + $ydir][$x]{char} eq $blankchar
#and $pos[$y + $ydir][$x]{terr} =~ /^blank/
) {
$pos[$y + $ydir][$x]{terr} = 'hall';
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x + $xdir]{char} eq $blankchar
#and $pos[$y + $ydir][$x]{terr} =~ /^blank/
) {
$pos[$y][$x + $xdir]{terr} = 'hall';
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
$x += $xdir;
$y += $ydir;
if (($y > $maxrows) or ($x > $maxcols)) {
warn "\n------------------------"
. "y$y,x$x,ydir$ydir,xdir$xdir\n"
if $debug > 4;
@pos = @save;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
}
if (($pos[$y][$x]{terr} eq 'wall') or
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
} else {
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
if (not $conn{$$rect{rect}}{$toroom}) {
# We've connected to a new room.
$conn{$$rect{rect}}{$toroom}++;
$conn{$toroom}{$$rect{rect}}++;
push @conn, $toroom;
$connected = 1;
print "N" if $debug > 12;
} else {
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe' if not ++$attempt %
$connectretry;
print "R" if $debug > 12;
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
$connected = 1;
push @conn, 'fail' if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} =~ /^rock/) {
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
print "\n" if $debug > 10;
}}
return @pos;
}
sub placeonfloor {
my ($rect, $grid) = @_;
my $miny = $$rect{roomgeom}{starty} + 1;
my $minx = $$rect{roomgeom}{startx} + 1;
my $maxy = $$rect{roomgeom}{stopy} - 1;
my $maxx = $$rect{roomgeom}{stopx} - 1;
print "[[$miny,$minx;$maxy,$maxx]]" if $debug > 8;
my $tried = 0;
while ($tried++ < 25) {
my $y = $miny + (int rand($maxy + 1 - $miny));
my $x = $minx + (int rand($maxx + 1 - $minx));
print "[$y,$x]" if $debug > 30;
if ($$grid[$y][$x]{terr} eq 'floor') {
return ($y, $x);
}}
return ($miny, $minx);
}
sub placefurniture {
my ($rects, $grid, $celly, $cellx, $terrain, $char, $colr, $y, $x) =
@_;
my @r = @$rects;
my $rect = $r[$celly][$cellx];
# use Data::Dumper; die Dumper(+{ rect => $rect, terr => $terrain,
char => $char });
if (ref $rect) {
if (ref $$rect{roomgeom}) {
($y, $x) = placeonfloor($rect, $grid) if not defined $x;
if ($$grid[$y][$x]{terr} eq 'floor') {
$$grid[$y][$x]{terr} = $terrain || 'ERROR';
$$grid[$y][$x]{char} = $char || $errorchar;
$$grid[$y][$x]{colr} = $colr || $errorcolor;
push @{$$grid[$y][$x]{furn}}, +{
y => $y,
x => $x,
type => $terrain,
};
if ($debug > 8) {
print "[$y,$x,$char]";
}
return [$y, $x];
} else {
print "<$$grid[$y][$x]{terr}>" if $debug > 30;
}
if ($debug > 8) {
print "N";
return;
}
} else {
print "X" if $debug > 8;
return;
}
} else {
print "-" if $debug > 8;
return;
}
}
sub placemonster {
my ($rects, $grid, $celly, $cellx, $type, $char, $colr) = @_;
my @r = @$rects;
my $rect = $r[$celly][$cellx];
if (ref $rect) {
if (ref $$rect{roomgeom}) {
my $tried = 0;
while ($tried++ < 15) {
# Only place one monster per tile:
my ($y, $x) = placeonfloor($rect, $grid);
print "[$y,$x]" if $debug > 30;
if (($$grid[$y][$x]{terr} eq 'floor') and
(not ref $$grid[$y][$x]{mons})){
$$grid[$y][$x]{mons} = +{
char => $char || $errorchar,
type => $type || 'MONSTER',
colr => $colr || 'reset',
};
if ($debug > 8) {
print "[$y,$x,$char]";
}
return [$y, $x];
} else {
print "<$$grid[$y][$x]{terr}>" if $debug > 30;
}
}
if ($debug > 8) {
print "N";
return;
}
} else {
print "X" if $debug > 8;
return;
}
} else {
print "-" if $debug > 8;
return;
}
}
sub rectcolor {
my ($n) = @_;
my @clr = ('white on_black', 'white on_blue',
'white on_red', 'white on_cyan',
'white on_green', 'white on_magenta',
'black on_white', 'black on_yellow');
while (((scalar @clr) > 1)
and (not ((scalar @cellcol) % (scalar @clr)))
) {
#warn "cell columns: " . scalar @cellcol;
#warn "colors is a factor: " . scalar @clr;
pop @clr;
}
#use Data::Dumper; print Dumper(\@clr); exit 0;
return $clr[$n % (scalar @clr)];
}
sub printlevel {
my (%a) = @_;
my @p = @{$a{level}};
print color 'reset';
print "\n";
if ($a{title}) {
my $spaces = int(($maxcols - (length $a{title})) / 2);
print " " x $spaces;
print "$a{title}\n\n";
}
for my $row (@p) {
for my $cell (@$row) {
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
#} elsif ($$cell{mons}{objs}) { # TODO
} else {
if ($a{debug} or ($debug > 3)) {
print color rectcolor($$cell{rect});
} else {
print color $$cell{colr} if $$cell{colr};
}
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
David Damerell
Nov 30, 2012, 8:20:07 AM11/30/12
to
Quoting Jonadab the Unsightly One <jonadab.the...@gmail.com>:
># If the idea of new kinds of levels to mix in with the
># mazes in Gehennom interests you, please run this Perl
># script a few times and let me know what you think.
># Specific suggestions are welcome.
Send it to roguebasin - there is always room for more dungeon generation
># If the idea of new kinds of levels to mix in with the
># mazes in Gehennom interests you, please run this Perl
># script a few times and let me know what you think.
># Specific suggestions are welcome.
algorithms.
--
David Damerell <dame...@chiark.greenend.org.uk>
Clown shoes. I hope that doesn't bother you.
Today is Leicesterday, November.
Tomorrow will be Brieday, November.
Benjamin A. Schmit
Nov 30, 2012, 9:25:20 AM11/30/12
to
$ ./dpr-old.pl
syntax error at ./dpr-old.pl line 1242, near "})"
Unmatched right curly bracket at ./dpr-old.pl line 1274, at end of line
syntax error at ./dpr-old.pl line 1274, near "}"
Can't use global @_ in "my" at ./dpr-old.pl line 1276, near "= @_"
syntax error at ./dpr-old.pl line 1313, near "}"
Can't use global @_ in "my" at ./dpr-old.pl line 1316, near "= @_"
syntax error at ./dpr-old.pl line 1330, near "}"
Can't use global @_ in "my" at ./dpr-old.pl line 1333, near "= @_"
syntax error at ./dpr-old.pl line 1368, near "}"
Execution of ./dpr-old.pl aborted due to compilation errors.
Looks like this got broken on posting (automatic line break) – here's a
quick patch:
---><8-------><8-------><8-------><8-------><8-------><8-------><8----
--- dpr-old.pl 2012-11-30 15:03:15.976781083 +0100
+++ dpr.pl 2012-11-30 15:07:23.760773762 +0100
@@ -1239,7 +1239,7 @@
+ # char => $char });
Apart from that, looks like a useful addition to the normal levels! The
grid is still too visible, IMHO.
I'd generate something like this in another way: Just create random
rectangular rooms and check whether their space on the map is still
empty (discard them if not). Iterate enough times and you'd get a
densely packed map without any grid structure. Then create features,
corridors, objects, and monsters as you do now. Possibly enhance the
process by starting with large rooms and somewhat reducing room size at
every step.
Benjamin
syntax error at ./dpr-old.pl line 1242, near "})"
Unmatched right curly bracket at ./dpr-old.pl line 1274, at end of line
syntax error at ./dpr-old.pl line 1274, near "}"
Can't use global @_ in "my" at ./dpr-old.pl line 1276, near "= @_"
syntax error at ./dpr-old.pl line 1313, near "}"
Can't use global @_ in "my" at ./dpr-old.pl line 1316, near "= @_"
syntax error at ./dpr-old.pl line 1330, near "}"
Can't use global @_ in "my" at ./dpr-old.pl line 1333, near "= @_"
syntax error at ./dpr-old.pl line 1368, near "}"
Execution of ./dpr-old.pl aborted due to compilation errors.
Looks like this got broken on posting (automatic line break) – here's a
quick patch:
---><8-------><8-------><8-------><8-------><8-------><8-------><8----
--- dpr-old.pl 2012-11-30 15:03:15.976781083 +0100
+++ dpr.pl 2012-11-30 15:07:23.760773762 +0100
@@ -1239,7 +1239,7 @@
my @r = @$rects;
my $rect = $r[$celly][$cellx];
# use Data::Dumper; die Dumper(+{ rect => $rect, terr => $terrain,
-char => $char });
my $rect = $r[$celly][$cellx];
# use Data::Dumper; die Dumper(+{ rect => $rect, terr => $terrain,
+ # char => $char });
if (ref $rect) {
if (ref $$rect{roomgeom}) {
($y, $x) = placeonfloor($rect, $grid) if not defined $x;
---><8-------><8-------><8-------><8-------><8-------><8-------><8----
if (ref $$rect{roomgeom}) {
($y, $x) = placeonfloor($rect, $grid) if not defined $x;
Apart from that, looks like a useful addition to the normal levels! The
grid is still too visible, IMHO.
I'd generate something like this in another way: Just create random
rectangular rooms and check whether their space on the map is still
empty (discard them if not). Iterate enough times and you'd get a
densely packed map without any grid structure. Then create features,
corridors, objects, and monsters as you do now. Possibly enhance the
process by starting with large rooms and somewhat reducing room size at
every step.
Benjamin
Jonadab the Unsightly One
Nov 30, 2012, 7:12:42 PM11/30/12
to
On Nov 30, 9:25 am, "Benjamin A. Schmit" <benjamin.sch...@gmail.com>
wrote:
yes, this is a valid concern, and an issue that
I was aware of but had not yet figured out
how to completely fix.
One thing I thought about was allowing
rooms that are not strictly rectangular
(e.g., rooms could be L-shaped), but I
wasn't sure how that would be received.
> create random rectangular rooms and check
> whether their space on the map is still empty
> (discard them if not). Iterate enough times
> and you'd get a densely packed map without
> any grid structure.
The problem with this is you'd end up with
areas where nothing (rectangular) would
fit. However...
> Possibly enhance the process by starting with
> large rooms and somewhat reducing room size
> at every step.
Now, there's an idea with potential. I may
do some experimenting with this notion
and see how it comes out.
I also have in mind to try a version where
instead of corridors the non-room areas
are all filled with maze(s), which connect
to the rooms at doors. However, I
haven't worked up the algorithm yet.
wrote:
> The grid is still too visible, IMHO.
Sometimes it's more visible than others, but
yes, this is a valid concern, and an issue that
I was aware of but had not yet figured out
how to completely fix.
One thing I thought about was allowing
rooms that are not strictly rectangular
(e.g., rooms could be L-shaped), but I
wasn't sure how that would be received.
> create random rectangular rooms and check
> whether their space on the map is still empty
> (discard them if not). Iterate enough times
> and you'd get a densely packed map without
> any grid structure.
areas where nothing (rectangular) would
fit. However...
> Possibly enhance the process by starting with
> large rooms and somewhat reducing room size
> at every step.
do some experimenting with this notion
and see how it comes out.
I also have in mind to try a version where
instead of corridors the non-room areas
are all filled with maze(s), which connect
to the rooms at doors. However, I
haven't worked up the algorithm yet.
Jonadab the Unsightly One
Dec 1, 2012, 8:48:03 AM12/1/12
to
On Nov 30, 7:12 pm, Jonadab the Unsightly One
> > create random rectangular rooms and check
> > whether their space on the map is still empty
> > (discard them if not). Iterate enough times
> > and you'd get a densely packed map without
> > any grid structure.
>
> The problem with this is you'd end up with
> areas where nothing (rectangular) would
> fit. However...
>
> > Possibly enhance the process by starting with
> > large rooms and somewhat reducing room size
> > at every step.
>
> Now, there's an idea with potential.
Perhaps something like this?
#!/usr/bin/perl
# -*- cperl -*-
# This is a Perl program that generates a proposed new type
# of NetHack level, consisting mostly of densely packed
# rooms of varying sizes, per Benjamin Schmit's suggestion.
# This is strictly experimental, and of course this Perl
# code will not integrate into NetHack, so in order to be
# used it would need to be reimplemented in C and integrated
# into NetHack's existing level-generation code.
my $maxroomwidth = $arg{maxroomwidth} || int($maxcols *
(0.2 + rand 0.25));
my $maxroomheight = $arg{maxroomheight} || int($maxrows *
(0.15 + rand 0.15));
my $minroomwidth = $arg{minroomwidth} || 2;# + int rand(2);
my $minroomheight = $arg{minroomheight} || 2;# + int rand(1);
my $dugchar = $arg{dugchar} || $corridorchar;
my $dugcolor = $arg{dugcolor} || 'white';
my $necornerchar = $arg{necornerchar} || "\\";
my $swcornerchar = $arg{swcornerchar} || "\\";
my $secornerchar = $arg{secornerchar} || '/';
my $widthdivisor = $arg{widthdivisor} || 2;
my $heightdivisor = $arg{heightdivisor} || 2;
use Term::ANSIColor;
my @pos = map {
my $y = $_ - 1;
[ map {
my $x = $_ - 1;
my $dug = (rand(100)<=$percentdugout) ? 1 : 0;
+{
posy => $y,
posx => $x,
char => $dug ? $dugchar : $blankchar,
room => undef,
terr => $dug ? 'dug (by default)' : 'rock (by default)',
colr => $dug ? $dugcolor : 'reset',
} 1 .. $maxcols ];
} 1 .. $maxrows;
my $targetwidth = $maxroomwidth;
my $targetheight = $maxroomheight;
my $availtiles = $maxrows * $maxcols;
my $roomnum = 0;
my $jotcount = 0;
my ($iteration, $totaliteration);
my @room;
while (($targetwidth >= $minroomwidth) and
($targetheight >= $minroomheight) and
($availtiles >= ($minroomwidth * $minroomheight * 10))) {
my $height = ($targetheight > 3)
? $targetheight - int rand rand $targetheight
: $targetheight;
my $width = ($targetwidth > 5)
? $targetwidth - int rand rand $targetwidth
: $targetwidth;
my $rect = randomrect($height, $width);
if (rectavailable($rect)) {
jot("+", 0);
push @room, makeroom($rect);
#use Data::Dumper; print Dumper(+{ room => \@room });
printlevel() if $debug > 3;
}
my $fitratio = int($availtiles * 5
/ ($targetwidth * $targetheight));
if ($iteration++ > $fitratio) {
# We've tried enough times at this size. Decrease size.
my $aspectratio = $targetwidth / $targetheight;
if (rand(100) <= (20 * $aspectratio)) {
$targetwidth -= (1 + int rand ($targetwidth /
$widthdivisor));
jot($_, 2) for split //, "W$targetwidth";
} else {
$targetheight -= (1 + int rand ($targetheight /
$heightdivisor));
jot($_, 2) for split //, "H$targetheight";
}
jot(" ");
$totaliteration += $iteration;
$iteration = 0;
} else {
jot();
}
}
# TODO: Put stuff in the rooms.
my ($didup, $diddown) = (0, 0);
my ($fountcount, $sinkcount, $altarcount, $gravecount,
$poolcount, $lavacount) = (0, 0, 0, 0, 0, 0);
for my $room (map { $$_[0]
} @room) {
'<', $upstaircolor);
} elsif (not $diddown) {
$diddown = placefurniture($room, 'stairs',
'>', $downstaircolor);
} $$room{startx} .. $$room{stopx};
} (($$room{starty} + 1) .. ($$room{stopy} - 1));
[$$room{stopy}, $x]
} reverse ($$room{startx} .. $$room{stopx});
} reverse (($$room{starty} + 1) .. ($$room{stopy} - 1));
$fountainchar, $fountaincolor)) {
$fountcount++; $roomfountcount++;
}}
$sinkchar, $sinkcolor)) {
$sinkcount++; $roomsinkcount++;
}}
$altarchar, $altarcolor)) {
$altarcount++;
if (rand(100) <= $priestprob) {
placemonster($room, 'aligned priest',
$priestchar, $priestcolor);
}}}
$gravechar, $gravecolor)) {
$gravecount++;
}}
# Terrain Features:
$poolchar, $poolcolor)) {
$poolcount++; $roompoolcount++;
}}
$lavachar, $lavacolor)) {
$lavacount++; $roomlavacount++;
}}
}}}
}
# TODO: Place Objects
}
}
# Place Corridors:
# TODO: This code needs revamped seriously.
for my $room (map { $$_[0]
} @room) {
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
$$origin{x} = $$room{startx} + int rand $floorwidth;
: $$room{startx} - 1;
$floorheight = $$room{stopy} - $$room{starty} + 1;
$$origin{y} = $$room{starty} + int rand $$floorheight;
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
my ($oldxdir, $oldydir);
while (not $connected) {
if ((rand(100) <= $corridortwist) and $corridorlength) {
if (not $conn{$$room{room}}{$toroom}) {
$conn{$toroom}{$$room{room}}++;
sub printlevel {
print color 'reset';
print "\n\n";
for my $row (@pos) {
} else {
my ($char, $mindebuglevel) = @_;
$char ||= '.';
$mindebuglevel ||= 1;
if ($mindebuglevel <= $debug) {
print $char;
if (not ($jotcount++ % 60)) {
print "\n";
}
}
}
sub randomrect {
my ($theight, $twidth) = @_;
my $maxy = $maxrows - $theight - 1;
my $maxx = $maxcols - $twidth - 1;
my $starty = 1 + int rand $maxy;
my $startx = 1 + int rand $maxx;
return +{
starty => $starty,
startx => $startx,
stopy => $starty + $theight - 1,
stopx => $startx + $twidth - 1,
};
}
sub rectavailable {
my ($rect) = @_;
return;
} elsif (not ($pos[$y][$x]{terr} =~ /default/)) {
return;
}
}
}
return $rect;
}
sub makeroom {
my ($room) = @_;
$$room{room} = ++$roomnum;
for my $y ($$room{starty} .. $$room{stopy}) {
for my $x ($$room{startx} .. $$room{stopx}) {
$pos[$y][$x]{room} = $roomnum;
}
}
# Horizontal Boundaries:
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
}
}
}
# Leave room for horizontal corridors:
for my $y (($$room{starty} - 2), ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2) .. ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}
}
}
# Vertical Boundaries:
for my $y (($$room{starty} - 1) .. ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
}
}
}
# Leave room for vertical corridors:
for my $y (($$room{starty} - 2) .. ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2), ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}
}
}
# Corners:
if (($$room{starty} >= 1) and ($$room{startx} >= 1)) {
$pos[$$room{starty} - 1][$$room{startx} - 1]{char}
= $nwcornerchar;
$pos[$$room{starty} - 1][$$room{startx} - 1]{crnr} = 1;
}
if (($$room{starty} >= 1) and ($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{starty} - 1][$$room{stopx} + 1]{char}
= $necornerchar;
$pos[$$room{starty} - 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and
($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{char}
= $secornerchar;
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and ($$room{startx} >= 1)) {
$pos[$$room{stopy} + 1][$$room{startx} - 1]{char}
= $swcornerchar;
$pos[$$room{stopy} + 1][$$room{startx} - 1]{crnr} = 1;
}
return $room;
}
sub placefurniture {
my ($room, $terrain, $char, $colr, $y, $x) = @_;
($y, $x) = placeonfloor($room) if not defined $x;
if ($pos[$y][$x]{terr} eq 'floor') {
$pos[$y][$x]{terr} = $terrain || 'ERROR';
$pos[$y][$x]{char} = $char || $errorchar;
$pos[$y][$x]{colr} = $colr || $errorcolor;
push @{$pos[$y][$x]{furn}}, +{
}
}
sub placemonster {
my ($room, $type, $char, $colr) = @_;
if (($pos[$y][$x]{terr} eq 'floor') and
(not ref $pos[$y][$x]{mons})){
$pos[$y][$x]{mons} = +{
}}
}
sub placeonfloor {
my ($room) = @_;
my $miny = $$room{starty};
my $minx = $$room{startx};
my $maxy = $$room{stopy};
my $maxx = $$room{stopx};
<jonadab.theunsightly...@gmail.com> wrote:
> One thing I thought about was allowing
> rooms that are not strictly rectangular
> (e.g., rooms could be L-shaped), but I
> wasn't sure how that would be received.
Still thinking about this.
> One thing I thought about was allowing
> rooms that are not strictly rectangular
> (e.g., rooms could be L-shaped), but I
> wasn't sure how that would be received.
> > create random rectangular rooms and check
> > whether their space on the map is still empty
> > (discard them if not). Iterate enough times
> > and you'd get a densely packed map without
> > any grid structure.
>
> The problem with this is you'd end up with
> areas where nothing (rectangular) would
> fit. However...
>
> > Possibly enhance the process by starting with
> > large rooms and somewhat reducing room size
> > at every step.
>
> Now, there's an idea with potential.
#!/usr/bin/perl
# -*- cperl -*-
# This is a Perl program that generates a proposed new type
# rooms of varying sizes, per Benjamin Schmit's suggestion.
# This is strictly experimental, and of course this Perl
# code will not integrate into NetHack, so in order to be
# used it would need to be reimplemented in C and integrated
# into NetHack's existing level-generation code.
(0.2 + rand 0.25));
my $maxroomheight = $arg{maxroomheight} || int($maxrows *
(0.15 + rand 0.15));
my $minroomwidth = $arg{minroomwidth} || 2;# + int rand(2);
my $minroomheight = $arg{minroomheight} || 2;# + int rand(1);
my $secretprob = $arg{secretprob} || 30;
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $percentdugout = $arg{percentdugout} || 20 + int rand 60;
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $dugchar = $arg{dugchar} || $corridorchar;
my $dugcolor = $arg{dugcolor} || 'white';
my $floorchar = $arg{floorchar} || '.';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $nwcornerchar = $arg{nwcornerchar} || '/';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $necornerchar = $arg{necornerchar} || "\\";
my $swcornerchar = $arg{swcornerchar} || "\\";
my $secornerchar = $arg{secornerchar} || '/';
my $errorchar = $arg{errorchar} || 'E';
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
my $wallcolor = $arg{wallcolor} || 'white on_black';
my $floorcolor = $arg{floorcolor} || 'reset';
my $doorcolor = $arg{doorcolor} || 'yellow on_black';
my $sdoorcolor = $arg{sdoorcolor} || $wallcolor;
my $corridorcolor = $arg{corridorcolor} || 'reset';
my $corridorfreq = $arg{corridorfreq} || 2 + int rand 2;
my $corridortwist = $arg{corridortwist} || 12;
my $connectretry = $arg{connectretry} || 3;
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
my $wallcolor = $arg{wallcolor} || 'white on_black';
my $floorcolor = $arg{floorcolor} || 'reset';
my $doorcolor = $arg{doorcolor} || 'yellow on_black';
my $sdoorcolor = $arg{sdoorcolor} || $wallcolor;
my $corridorcolor = $arg{corridorcolor} || 'reset';
my $corridorfreq = $arg{corridorfreq} || 2 + int rand 2;
my $corridortwist = $arg{corridortwist} || 12;
my $connectretry = $arg{connectretry} || 3;
my $heightdivisor = $arg{heightdivisor} || 2;
my @pos = map {
my $y = $_ - 1;
[ map {
my $x = $_ - 1;
my $dug = (rand(100)<=$percentdugout) ? 1 : 0;
+{
posy => $y,
posx => $x,
char => $dug ? $dugchar : $blankchar,
room => undef,
terr => $dug ? 'dug (by default)' : 'rock (by default)',
colr => $dug ? $dugcolor : 'reset',
furn => [],
objs => [],
mons => undef,
};
objs => [],
mons => undef,
} 1 .. $maxcols ];
} 1 .. $maxrows;
my $targetwidth = $maxroomwidth;
my $targetheight = $maxroomheight;
my $availtiles = $maxrows * $maxcols;
my $roomnum = 0;
my $jotcount = 0;
my ($iteration, $totaliteration);
my @room;
while (($targetwidth >= $minroomwidth) and
($targetheight >= $minroomheight) and
($availtiles >= ($minroomwidth * $minroomheight * 10))) {
my $height = ($targetheight > 3)
? $targetheight - int rand rand $targetheight
: $targetheight;
my $width = ($targetwidth > 5)
? $targetwidth - int rand rand $targetwidth
: $targetwidth;
my $rect = randomrect($height, $width);
if (rectavailable($rect)) {
jot("+", 0);
push @room, makeroom($rect);
#use Data::Dumper; print Dumper(+{ room => \@room });
printlevel() if $debug > 3;
}
my $fitratio = int($availtiles * 5
/ ($targetwidth * $targetheight));
if ($iteration++ > $fitratio) {
# We've tried enough times at this size. Decrease size.
my $aspectratio = $targetwidth / $targetheight;
if (rand(100) <= (20 * $aspectratio)) {
$targetwidth -= (1 + int rand ($targetwidth /
$widthdivisor));
jot($_, 2) for split //, "W$targetwidth";
} else {
$targetheight -= (1 + int rand ($targetheight /
$heightdivisor));
jot($_, 2) for split //, "H$targetheight";
}
jot(" ");
$totaliteration += $iteration;
$iteration = 0;
} else {
jot();
}
}
# TODO: Put stuff in the rooms.
my ($didup, $diddown) = (0, 0);
my ($fountcount, $sinkcount, $altarcount, $gravecount,
$poolcount, $lavacount) = (0, 0, 0, 0, 0, 0);
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
my ($roomfountcount, $roomsinkcount,
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
my $special;
if (not $didup) {
$didup = placefurniture($room, 'stairs',
if (not $didup) {
'<', $upstaircolor);
} elsif (not $diddown) {
$diddown = placefurniture($room, 'stairs',
'>', $downstaircolor);
} else {
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
if (rand(100)<=60) {
$special = 'dragon lair';
} # TODO: more special-room options
}}
if ($special eq 'statue hall') {
my @bordertile;
my $statuecount;
push @bordertile, $_ for map {
my $x = $_;
[$$room{starty}, $x]
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
if (rand(100)<=60) {
$special = 'dragon lair';
} # TODO: more special-room options
}}
if ($special eq 'statue hall') {
my @bordertile;
my $statuecount;
push @bordertile, $_ for map {
my $x = $_;
} $$room{startx} .. $$room{stopx};
push @bordertile, $_ for map {
my $y = $_;
[$y, $$room{stopx}]
my $y = $_;
} (($$room{starty} + 1) .. ($$room{stopy} - 1));
push @bordertile, $_ for map {
my $x = $_;
[$$room{stopy}, $x]
} reverse ($$room{startx} .. $$room{stopx});
push @bordertile, $_ for map {
my $y = $_;
[$y, $$room{startx}]
my $y = $_;
} reverse (($$room{starty} + 1) .. ($$room{stopy} - 1));
my $spacing = (defined $statuespacing)
? $statuespacing : ((int rand(5)) ? 1 : rand(3));
while (scalar @bordertile) {
my $tile = shift @bordertile;
placefurniture($room, 'statue', $statuechar,
? $statuespacing : ((int rand(5)) ? 1 : rand(3));
while (scalar @bordertile) {
my $tile = shift @bordertile;
$statuecolor, @$tile);
for (1 .. $spacing) {
shift @bordertile if scalar @bordertile;
}}
# TODO: also place some traps in the room.
} elsif ($special eq 'dragon lair') {
my %dragoncolor = (black => 'bold black',
red => 'bold red',
blue => 'blue',
gray => 'white');
my @color = keys %dragoncolor;
my $color = $color[rand @color];
placemonster($room, "great $color dragon",
for (1 .. $spacing) {
shift @bordertile if scalar @bordertile;
}}
# TODO: also place some traps in the room.
} elsif ($special eq 'dragon lair') {
my %dragoncolor = (black => 'bold black',
red => 'bold red',
blue => 'blue',
gray => 'white');
my @color = keys %dragoncolor;
my $color = $color[rand @color];
'D', $dragoncolor{$color});
placemonster($room, "$color dragon",
'D', $dragoncolor{$color})
for 1 .. (2 + int rand 3);
placemonster($room, "baby $color dragon",
for 1 .. (2 + int rand 3);
'D', $dragoncolor{$color})
for 1 .. (3 + int rand 4);
# TODO: place gold and gems and thematic stuff
#} elsif ($special eq 'another option') { # TODO
} else {
while ((rand(100) <= $fountainprob) and
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
if (placefurniture($room, 'fountain',
for 1 .. (3 + int rand 4);
# TODO: place gold and gems and thematic stuff
#} elsif ($special eq 'another option') { # TODO
} else {
while ((rand(100) <= $fountainprob) and
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
$fountainchar, $fountaincolor)) {
$fountcount++; $roomfountcount++;
}}
while ((rand(100) <= $sinkprob) and
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
if (placefurniture($room, 'sink',
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
$sinkchar, $sinkcolor)) {
$sinkcount++; $roomsinkcount++;
}}
if ((rand(100) <= $altarprob) and
($altarcount < $maxaltars)) {
if (placefurniture($room, 'altar',
($altarcount < $maxaltars)) {
$altarchar, $altarcolor)) {
$altarcount++;
if (rand(100) <= $priestprob) {
placemonster($room, 'aligned priest',
$priestchar, $priestcolor);
}}}
if ((rand(100) <= $graveprob) and
($gravecount < $maxgraves)) {
if (placefurniture($room, 'grave',
($gravecount < $maxgraves)) {
$gravechar, $gravecolor)) {
$gravecount++;
}}
# Terrain Features:
while ((rand(100) <= ($roompoolcount
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
if (placefurniture($room, 'pool',
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
$poolchar, $poolcolor)) {
$poolcount++; $roompoolcount++;
}}
while ((rand(100) <= ($roomlavacount
? $morelavaprob
: $lavaprob))
and (lavacount < $maxlava)
and ($roomlavacount < $maxroomlava)
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
if (placefurniture($room, 'lava',
? $morelavaprob
: $lavaprob))
and (lavacount < $maxlava)
and ($roomlavacount < $maxroomlava)
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
$lavachar, $lavacolor)) {
$lavacount++; $roomlavacount++;
}}
my $roommonstcount = 0;
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
$roommonstcount++
if placemonster($room, $mtype, $mchar, $mcolor);
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
$roommonstcount++
if (rand(100)<= $mongroupprob) {
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
$roommonstcount++
if placemonster($room, $mtype, $mchar, $mcolor);
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
$roommonstcount++
}}}
}
# TODO: Place Objects
}
}
# Place Corridors:
# TODO: This code needs revamped seriously.
for my $room (map { $$_[0]
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
my @conn, %conn, $attempt;
my $cwanted = 1 + int rand $corridorfreq;
my $cwanted = 1 + int rand $corridorfreq;
while ($cwanted > scalar @conn) {
my ($xdir, $ydir, $origin) = (0, 0, +{});
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my ($xdir, $ydir, $origin) = (0, 0, +{});
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my $originok = 0;
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
$origindir =
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
# origin must be top or bottom
$$origin{y} = ($ydir > 0)
? $$room{stopy} + 1
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
# origin must be top or bottom
$$origin{y} = ($ydir > 0)
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
$$origin{x} = $$room{startx} + int rand $floorwidth;
} else {
# origin must be on the side
$$origin{x} = ($xdir > 0)
? $$room{stopx} + 1
# origin must be on the side
$$origin{x} = ($xdir > 0)
: $$room{startx} - 1;
$floorheight = $$room{stopy} - $$room{starty} + 1;
$$origin{y} = $$room{starty} + int rand $$floorheight;
}
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# Do not allow origin at map edge:
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
while (not $connected) {
print "." if $debug > 12;
my $loopcount = 0;
if ((rand(100) <= $corridortwist) and $corridorlength) {
($oldxdir, $oldydir) = ($xdir, $ydir);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
$ydir = int rand(3) - 1;
}
while ((($x + $xdir < 0) or
($x + $xdir >= $maxcols) or
($y + $ydir < 0) or
($y + $ydir >= $maxrows) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y + $ydir][$x]{char} eq $blankchar) {
$ydir = int rand(3) - 1;
}
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
$pos[$y + $ydir][$x]{terr} = 'hall';
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x + $xdir]{char} eq $blankchar) {
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
$pos[$y][$x + $xdir]{terr} = 'hall';
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
$x += $xdir;
$y += $ydir;
$corridorlength++;
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
$x += $xdir;
$y += $ydir;
if (($y > $maxrows) or ($x > $maxcols)) {
# We've connected to a new room.
$conn{$$room{room}}{$toroom}++;
$conn{$toroom}{$$room{room}}++;
push @conn, $toroom;
$connected = 1;
$connected = 1;
} else {
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe' if not ++$attempt % $connectretry;
}
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe' if not ++$attempt % $connectretry;
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
$connected = 1;
push @conn, 'fail' if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} =~ /rock|default/) {
$connected = 1;
push @conn, 'fail' if not ++$attempt % $connectretry;
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
}
printlevel();
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
}
sub printlevel {
print color 'reset';
print "\n\n";
for my $row (@pos) {
for my $cell (@$row) {
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
#} elsif ($$cell{objs}) { # TODO
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
} else {
print color $$cell{colr} if $$cell{colr};
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
sub jot {
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
my ($char, $mindebuglevel) = @_;
$char ||= '.';
$mindebuglevel ||= 1;
if ($mindebuglevel <= $debug) {
print $char;
if (not ($jotcount++ % 60)) {
print "\n";
}
}
}
sub randomrect {
my ($theight, $twidth) = @_;
my $maxy = $maxrows - $theight - 1;
my $maxx = $maxcols - $twidth - 1;
my $starty = 1 + int rand $maxy;
my $startx = 1 + int rand $maxx;
return +{
starty => $starty,
startx => $startx,
stopy => $starty + $theight - 1,
stopx => $startx + $twidth - 1,
};
}
sub rectavailable {
my ($rect) = @_;
for my $y ($$rect{starty} .. $$rect{stopy}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
if (defined $pos[$y][$x]{room}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
return;
} elsif (not ($pos[$y][$x]{terr} =~ /default/)) {
return;
}
}
}
return $rect;
}
sub makeroom {
my ($room) = @_;
$$room{room} = ++$roomnum;
for my $y ($$room{starty} .. $$room{stopy}) {
for my $x ($$room{startx} .. $$room{stopx}) {
$pos[$y][$x]{room} = $roomnum;
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}
}
# Horizontal Boundaries:
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
}
}
}
# Leave room for horizontal corridors:
for my $y (($$room{starty} - 2), ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2) .. ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}
}
}
# Vertical Boundaries:
for my $y (($$room{starty} - 1) .. ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
}
}
}
# Leave room for vertical corridors:
for my $y (($$room{starty} - 2) .. ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2), ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}
}
}
# Corners:
if (($$room{starty} >= 1) and ($$room{startx} >= 1)) {
$pos[$$room{starty} - 1][$$room{startx} - 1]{char}
= $nwcornerchar;
$pos[$$room{starty} - 1][$$room{startx} - 1]{crnr} = 1;
}
if (($$room{starty} >= 1) and ($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{starty} - 1][$$room{stopx} + 1]{char}
= $necornerchar;
$pos[$$room{starty} - 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and
($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{char}
= $secornerchar;
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and ($$room{startx} >= 1)) {
$pos[$$room{stopy} + 1][$$room{startx} - 1]{char}
= $swcornerchar;
$pos[$$room{stopy} + 1][$$room{startx} - 1]{crnr} = 1;
}
return $room;
}
sub placefurniture {
my ($room, $terrain, $char, $colr, $y, $x) = @_;
($y, $x) = placeonfloor($room) if not defined $x;
if ($pos[$y][$x]{terr} eq 'floor') {
$pos[$y][$x]{terr} = $terrain || 'ERROR';
$pos[$y][$x]{char} = $char || $errorchar;
$pos[$y][$x]{colr} = $colr || $errorcolor;
push @{$pos[$y][$x]{furn}}, +{
y => $y,
x => $x,
type => $terrain,
};
return [$y, $x];
x => $x,
type => $terrain,
};
}
}
sub placemonster {
my ($room, $type, $char, $colr) = @_;
my $tried = 0;
while ($tried++ < 15) {
# Only place one monster per tile:
my ($y, $x) = placeonfloor($room);
while ($tried++ < 15) {
# Only place one monster per tile:
if (($pos[$y][$x]{terr} eq 'floor') and
(not ref $pos[$y][$x]{mons})){
$pos[$y][$x]{mons} = +{
char => $char || $errorchar,
type => $type || 'MONSTER',
colr => $colr || 'reset',
};
return [$y, $x];
type => $type || 'MONSTER',
colr => $colr || 'reset',
};
}}
}
sub placeonfloor {
my ($room) = @_;
my $miny = $$room{starty};
my $minx = $$room{startx};
my $maxy = $$room{stopy};
my $maxx = $$room{stopx};
my $tried = 0;
while ($tried++ < 25) {
my $y = $miny + (int rand($maxy + 1 - $miny));
my $x = $minx + (int rand($maxx + 1 - $minx));
print "[$y,$x]" if $debug > 30;
if ($pos[$y][$x]{terr} eq 'floor') {
while ($tried++ < 25) {
my $y = $miny + (int rand($maxy + 1 - $miny));
my $x = $minx + (int rand($maxx + 1 - $minx));
print "[$y,$x]" if $debug > 30;
Benjamin A. Schmit
Dec 3, 2012, 6:35:59 AM12/3/12
to
[ Sorry for replying by mail the first time. Thunderbird has moved the
fire button… ]
2012-12-01 14:48 – Jonadab the Unsightly One:
>>> Possibly enhance the process by starting with
>>> large rooms and somewhat reducing room size
>>> at every step.
>> Now, there's an idea with potential.
> Perhaps something like this?
This looks quite good to me – I'd love to see those instead of some of
the maze levels in Gehennom.
Benjamin
--
Seek freedom and become captive of your desires.
Seek discipline and find your liberty.
-- Frank Herbert, Dune Chronicles
fire button… ]
2012-12-01 14:48 – Jonadab the Unsightly One:
> On Nov 30, 7:12 pm, Jonadab the Unsightly One <jonadab.theunsightly...@gmail.com> wrote:
>> One thing I thought about was allowing
>> rooms that are not strictly rectangular
>> (e.g., rooms could be L-shaped), but I
>> wasn't sure how that would be received.
> Still thinking about this.
>
>>> create random rectangular rooms and check
>>> whether their space on the map is still empty
>>> (discard them if not). Iterate enough times
>>> and you'd get a densely packed map without
>>> any grid structure.
>> The problem with this is you'd end up with
>> areas where nothing (rectangular) would
>> fit. However...
Not sure if that matters – there must be some place for corridors as well…
>> One thing I thought about was allowing
>> rooms that are not strictly rectangular
>> (e.g., rooms could be L-shaped), but I
>> wasn't sure how that would be received.
> Still thinking about this.
>
>>> create random rectangular rooms and check
>>> whether their space on the map is still empty
>>> (discard them if not). Iterate enough times
>>> and you'd get a densely packed map without
>>> any grid structure.
>> The problem with this is you'd end up with
>> areas where nothing (rectangular) would
>> fit. However...
>>> Possibly enhance the process by starting with
>>> large rooms and somewhat reducing room size
>>> at every step.
>> Now, there's an idea with potential.
> Perhaps something like this?
the maze levels in Gehennom.
Benjamin
--
Seek freedom and become captive of your desires.
Seek discipline and find your liberty.
-- Frank Herbert, Dune Chronicles
Jonadab the Unsightly One
Dec 5, 2012, 12:21:25 PM12/5/12
to
#!/usr/bin/perl
# -*- cperl -*-
# This is a Perl program that generates the following
# -*- cperl -*-
# proposed new types of NetHack level styles:
# 1. levels consisting mostly of densely packed rooms of
# varying sizes, per Benjamin Schmit's suggestion.
# 2. levels containing rectangular rooms that may overlap,
# resulting in extra walls partitioning them into sections.
# 3. levels containing possibly non-rectangular rooms
# (of several different types) and corridors.
# This is all strictly experimental, and of course this Perl
# code will not integrate into NetHack, so in order to be
# used it would need to be reimplemented in C and integrated
# into NetHack's existing level-generation code.
# If implemented, these types of levels could be used in
# custom dungeon content, in special levels (e.g., quest
# filler levels for proposed new roles), and potentially
# in Gehennom to replace some of the maze levels.
# Note that these levels should NOT be used very early in
# the dungeons, because they may contain disconnected areas
# that can only be reached by digging or teleport, as well
# as water and/or lava that may need to be traversed in some
# cases. Also, the special rooms contain monsters that a
# pre-quest, pre-castle character should not have to face.
# In other words, these are strictly late-game levels.
# Don't worry if the choices of monsters seem odd. Except
# for special rooms, this script does not attempt realistic
# monster generation, because the intention is that the
# existing monster generation code be used. So while this
# script does pepper the levels with random monsters, that's
# just so they don't look totally bare.
# Other than that, there are still a few bugs to work out
# used it would need to be reimplemented in C and integrated
# into NetHack's existing level-generation code.
# If implemented, these types of levels could be used in
# custom dungeon content, in special levels (e.g., quest
# filler levels for proposed new roles), and potentially
# in Gehennom to replace some of the maze levels.
# Note that these levels should NOT be used very early in
# the dungeons, because they may contain disconnected areas
# that can only be reached by digging or teleport, as well
# as water and/or lava that may need to be traversed in some
# cases. Also, the special rooms contain monsters that a
# pre-quest, pre-castle character should not have to face.
# In other words, these are strictly late-game levels.
# Don't worry if the choices of monsters seem odd. Except
# for special rooms, this script does not attempt realistic
# monster generation, because the intention is that the
# existing monster generation code be used. So while this
# script does pepper the levels with random monsters, that's
# just so they don't look totally bare.
# Other than that, there are still a few bugs to work out
# but I think it's reached the point where it's worth
# soliciting feedback...
# If the idea of new kinds of levels to mix in with the
# mazes in Gehennom interests you, please run this Perl
# script a few times and let me know what you think.
# Specific suggestions are welcome.
my %arg = @ARGV;
my $layoutstyle = $arg{layoutstyle} || 1 + int rand 3;
# soliciting feedback...
# If the idea of new kinds of levels to mix in with the
# mazes in Gehennom interests you, please run this Perl
# script a few times and let me know what you think.
# Specific suggestions are welcome.
my %arg = @ARGV;
my $debug = $arg{debug} || 3;
my $maxrows = $arg{maxrows} || 24;
my $maxcols = $arg{maxcols} || 65 + int rand(4);
my $maxroomwidth = $arg{maxroomwidth} || int($maxcols *
(0.2 + rand 0.25));
my $maxroomheight = $arg{maxroomheight} || int($maxrows *
(0.15 + rand 0.15));
my $minroomwidth = $arg{minroomwidth} || 2;# + int rand(2);
my $minroomheight = $arg{minroomheight} || 2;# + int rand(1);
my $secretprob = $arg{secretprob} || 30;
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $percentdugout = $arg{percentdugout} || 20 + irr(60);
my $maxrows = $arg{maxrows} || 24;
my $maxcols = $arg{maxcols} || 65 + int rand(4);
my $maxroomwidth = $arg{maxroomwidth} || int($maxcols *
(0.2 + rand 0.25));
my $maxroomheight = $arg{maxroomheight} || int($maxrows *
(0.15 + rand 0.15));
my $minroomwidth = $arg{minroomwidth} || 2;# + int rand(2);
my $minroomheight = $arg{minroomheight} || 2;# + int rand(1);
my $secretprob = $arg{secretprob} || 30;
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $dugchar = $arg{dugchar} || $corridorchar;
my $dugcolor = $arg{dugcolor} || 'white';
my $floorchar = $arg{floorchar} || '.';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $nwcornerchar = $arg{nwcornerchar} || '/';
my $necornerchar = $arg{necornerchar} || "\\";
my $swcornerchar = $arg{swcornerchar} || "\\";
my $secornerchar = $arg{secornerchar} || '/';
my $errorchar = $arg{errorchar} || 'E';
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
my $dugcolor = $arg{dugcolor} || 'white';
my $floorchar = $arg{floorchar} || '.';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $nwcornerchar = $arg{nwcornerchar} || '/';
my $necornerchar = $arg{necornerchar} || "\\";
my $swcornerchar = $arg{swcornerchar} || "\\";
my $secornerchar = $arg{secornerchar} || '/';
my $errorchar = $arg{errorchar} || 'E';
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
$wallcolor = $arg{wallcolor} || 'white on_black';
my $roomnum = 0;
my $jotcount = 0;
my @room;
my $jotcount = 0;
my %layoutname = (
1 => 'Dense Room Packing',
2 => 'Overlapping Rectangles',
3 => 'Non-Rectangular Rooms',
);
my @randcolor = ('cyan', 'blue', 'green', 'red', 'magenta',
'bold black', 'bold cyan', 'bold blue',
'bold green', 'bold red', 'bold yellow',
'bold magenta', 'bold white'
);
if ($layoutstyle == 1) {
layout_dense_rooms();
} elsif ($layoutstyle == 2) {
layout_overlapping_rooms();
} elsif ($layoutstyle == 3) {
layout_non_rectangular_rooms();
} else {
die "Unknown layout style: $layoutstyle";
}
# Put stuff in the rooms...
my ($didup, $diddown) = (0, 0);
my ($fountcount, $sinkcount, $altarcount, $gravecount,
$poolcount, $lavacount) = (0, 0, 0, 0, 0, 0);
for my $room (map { $$_[0]
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
my ($roomfountcount, $roomsinkcount,
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
my $special;
if (not $didup) {
$didup = placefurniture($room, 'stairs',
'<', $upstaircolor);
jot("<") if $debug > 5;
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
my $special;
if (not $didup) {
$didup = placefurniture($room, 'stairs',
'<', $upstaircolor);
} elsif (not $diddown) {
$diddown = placefurniture($room, 'stairs',
'>', $downstaircolor);
jot(">") if $debug > 5;
$diddown = placefurniture($room, 'stairs',
'>', $downstaircolor);
} else {
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
jot("S") if $debug > 5;
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
if (rand(100)<=40) {
$special = 'dragon lair';
jot("D") if $debug > 6;
} elsif (rand(100)<=50) {
$special = 'garden of temptation';
jot("G") if $debug > 6;
my @gmonst = (
['succubus', '&', 'reset'],
['incubus', '&', 'reset'],
['incubus', '&', 'reset'],
['mountain nymph', 'n', 'yellow'],
['water nymph', 'n', 'blue'],
['wood nymph', 'n', 'green'],
);
my @gfurn = (
['tree', '#', 'green'],
['tree', '#', 'green'],
['fountain', $fountainchar, $fountaincolor],
['pool', $poolchar, $poolcolor],
);
for (1 .. 4) {
my $f = $gfurn[rand @gfurn];
my $m = $gmonst[rand @gmonst];
placefurniture($room, @$f);
placemonster($room, @$m);
placemonster($room, @$m);
}
} else {
jot("R") if $debug > 5;
while ((rand(100) <= $fountainprob) and
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
if (placefurniture($room, 'fountain',
$fountainchar, $fountaincolor)) {
$fountcount++; $roomfountcount++;
jot($fountchar) if $debug > 6;
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
if (placefurniture($room, 'fountain',
$fountainchar, $fountaincolor)) {
$fountcount++; $roomfountcount++;
}}
while ((rand(100) <= $sinkprob) and
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
if (placefurniture($room, 'sink',
$sinkchar, $sinkcolor)) {
$sinkcount++; $roomsinkcount++;
jot($sinkchar) if $debug > 6;
while ((rand(100) <= $sinkprob) and
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
if (placefurniture($room, 'sink',
$sinkchar, $sinkcolor)) {
$sinkcount++; $roomsinkcount++;
}}
if ((rand(100) <= $altarprob) and
($altarcount < $maxaltars)) {
if (placefurniture($room, 'altar',
$altarchar, $altarcolor)) {
$altarcount++;
jot($altarchar) if $debug > 6;
if ((rand(100) <= $altarprob) and
($altarcount < $maxaltars)) {
if (placefurniture($room, 'altar',
$altarchar, $altarcolor)) {
$altarcount++;
if (rand(100) <= $priestprob) {
placemonster($room, 'aligned priest',
$priestchar, $priestcolor);
jot($priestchar) if $debug > 6;
placemonster($room, 'aligned priest',
$priestchar, $priestcolor);
}}}
if ((rand(100) <= $graveprob) and
($gravecount < $maxgraves)) {
if (placefurniture($room, 'grave',
$gravechar, $gravecolor)) {
$gravecount++;
jot($gravechar) if $debug > 6;
if ((rand(100) <= $graveprob) and
($gravecount < $maxgraves)) {
if (placefurniture($room, 'grave',
$gravechar, $gravecolor)) {
$gravecount++;
}}
# Terrain Features:
while ((rand(100) <= ($roompoolcount
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
if (placefurniture($room, 'pool',
$poolchar, $poolcolor)) {
$poolcount++; $roompoolcount++;
jot($poolchar) if $debug > 6;
# Terrain Features:
while ((rand(100) <= ($roompoolcount
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
if (placefurniture($room, 'pool',
$poolchar, $poolcolor)) {
$poolcount++; $roompoolcount++;
}}
while ((rand(100) <= ($roomlavacount
? $morelavaprob
: $lavaprob))
and (lavacount < $maxlava)
and ($roomlavacount < $maxroomlava)
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
if (placefurniture($room, 'lava',
$lavachar, $lavacolor)) {
$lavacount++; $roomlavacount++;
jot($lavachar) if $debug > 6;
while ((rand(100) <= ($roomlavacount
? $morelavaprob
: $lavaprob))
and (lavacount < $maxlava)
and ($roomlavacount < $maxroomlava)
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
if (placefurniture($room, 'lava',
$lavachar, $lavacolor)) {
$lavacount++; $roomlavacount++;
}}
my $roommonstcount = 0;
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
if (placemonster($room, $mtype, $mchar, $mcolor)) {
my $roommonstcount = 0;
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
$roommonstcount++;
jot($mchar) if $debug > 6;
}
if (rand(100)<= $mongroupprob) {
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
if (placemonster($room, $mtype, $mchar, $mcolor)) {
if (rand(100)<= $mongroupprob) {
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
$roommonstcount++;
jot("+") if $debug > 6;
}
}}}
}
# TODO: Place Objects
}
}
print "\nPlacing corridors...\n" if $debug;
# Place Corridors:
for my $room (map { $$_[0]
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
my @conn, %conn, $attempt;
my $cwanted = 1 + int rand $corridorfreq;
$cwanted = int($cwanted * 1.75) if $layoutstyle == 2;
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
my @conn, %conn, $attempt;
my $cwanted = 1 + int rand $corridorfreq;
if ($debug > 10) {
printlevel();
}
jot($_) for split //, " R$$room{room}CW$cwanted ";
while (($cwanted > scalar @conn) and ($attempt < 25)) {
jot("-");
my ($xdir, $ydir, $origin) = (0, 0, +{});
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my $originok = 0;
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
$origindir =
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
jot("V") if $debug > 6;
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my $originok = 0;
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
$origindir =
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
# origin must be top or bottom
jot(($ydir>0) ? "n" : "s") if $debug > 7;
$$origin{y} = ($ydir > 0)
? $$room{stopy} + 1
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
$$origin{x} = $$room{startx} + int rand $floorwidth;
} else { jot("H") if $debug > 6;
? $$room{stopy} + 1
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
$$origin{x} = $$room{startx} + int rand $floorwidth;
# origin must be on the side
jot(($xdir>0) ? "e" : "w") if $debug > 7;
$$origin{x} = ($xdir > 0)
? $$room{stopx} + 1
: $$room{startx} - 1;
$floorheight = $$room{stopy} - $$room{starty} + 1;
$$origin{y} = $$room{starty} + int rand $$floorheight;
}
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# Do not allow origin at map edge:
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
if ($originok) {
jot("O");
? $$room{stopx} + 1
: $$room{startx} - 1;
$floorheight = $$room{stopy} - $$room{starty} + 1;
$$origin{y} = $$room{starty} + int rand $$floorheight;
}
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# Do not allow origin at map edge:
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
if ($originok) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
jot("A") if $debug > 6;
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
} else {
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
if ($debug > 6) {
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
my $color = $randcolor[rand @randcolor];
$pos[$$origin{y}][$$origin{x}]{colr} = $color;
print color $color;
jot($doorchar);
print color 'reset';
}
}
my $x = $$origin{x};
my $y = $$origin{y};
jot($_) for split //, "y$y,x$x";
}
my $x = $$origin{x};
my $y = $$origin{y};
my $connected = undef;
my ($oldxdir, $oldydir);
while (not $connected) {
jot(",") if $debug > 20;
my ($oldxdir, $oldydir);
while (not $connected) {
my $loopcount = 0;
if ((rand(100) <= $corridortwist) and $corridorlength) {
($oldxdir, $oldydir) = ($xdir, $ydir);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
jot("T") if $debug > 7;
if ((rand(100) <= $corridortwist) and $corridorlength) {
($oldxdir, $oldydir) = ($xdir, $ydir);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
while ((($x + $xdir < 0) or
($x + $xdir >= $maxcols) or
($y + $ydir < 0) or
($y + $ydir >= $maxrows) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
while ((($x + $xdir < 0) or
($x + $xdir >= $maxcols) or
($y + $ydir < 0) or
($y + $ydir >= $maxrows) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
$xdir *= -1 if (($x + $xdir < 0) or
($x + $xdir >= $maxcols));
$ydir *= -1 if (($y + $ydir < 0) or
($y + $ydir >= $maxrows));
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y + $ydir][$x]{char} eq $blankchar) {
$pos[$y + $ydir][$x]{terr} = 'hall';
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x + $xdir]{char} eq $blankchar) {
$pos[$y][$x + $xdir]{terr} = 'hall';
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y + $ydir][$x]{char} eq $blankchar) {
$pos[$y + $ydir][$x]{terr} = 'hall';
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x + $xdir]{char} eq $blankchar) {
$pos[$y][$x + $xdir]{terr} = 'hall';
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
$x += $xdir;
$y += $ydir;
$corridorlength++ if ($xdir or $ydir);
$y += $ydir;
jot(".") if $debug > 8;
if (($y > $maxrows) or ($x > $maxcols)
or ($x < 0) or ($y < 0)) {
@pos = @save;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
jot("e") if $debug > 7;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
}
if (($pos[$y][$x]{terr} eq 'wall') or
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
jot("a") if $debug > 7;
if (($pos[$y][$x]{terr} eq 'wall') or
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
} else {
jot($doorchar) if $debug > 7;
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
if (not $conn{$$room{room}}{$toroom}) {
# We've connected to a new room.
$conn{$$room{room}}{$toroom}++;
$conn{$toroom}{$$room{room}}++;
push @conn, $toroom;
$connected = 1;
jot("*") if $debug > 6;
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
if (not $conn{$$room{room}}{$toroom}) {
# We've connected to a new room.
$conn{$$room{room}}{$toroom}++;
$conn{$toroom}{$$room{room}}++;
push @conn, $toroom;
$connected = 1;
} else {
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe' if not ++$attempt % $connectretry;
jot("d") if $debug > 7;
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe' if not ++$attempt % $connectretry;
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
$connected = 1;
jot("f") if $debug > 6;
} elsif ($pos[$y][$x]{terr} eq 'hall') {
$connected = 1;
push @conn, 'fail' if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} eq 'floor') {
$connected = 1;
jot("?") if $debug > 6;
push @conn, '????' if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} =~ /rock|default/) {
jot("#") if $debug > 8;
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
}
printlevel();
exit 0; # ---------------- Subroutines follow --------------------
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
}
printlevel();
sub layout_non_rectangular_rooms {
$maxwidth += irr(($maxcols - $maxroomwidth) * 2/3);
$maxheight += irr(($maxrows - $maxroomheight) * 2/3);
my $avgwidth = ($minroomwidth + $maxroomwidth) / 2;
my $avgheight = ($minroomheight + $maxroomheight) / 2;
my $numofrooms = ($maxcols / $avgwidth)
* ($maxrows / $avgheight);
$numofrooms = int(
($numofrooms / 3)
+ rand($numofrooms / 3)
);
my $tries = 0;
while (($numofrooms > scalar @room) and ($tries++ < 50)) {
my $targetwidth = $maxroomwidth
- int rand($maxroomwidth - $minroomwidth);
my $targetheight = $maxroomheight
- int rand($maxroomheight - $minroomheight);
print "\nT";
jot($_) for split //, ('W' . $targetwidth
."H" . $targetheight . ":");
my $mainrect = randomrect($targetheight, $targetwidth);
if (rectavailable($mainrect)) {
$$mainrect{room} = ++$roomnum;
jot("R"); jot($_) for split //, $roomnum;
jot($_) for split //,
qq[x$$mainrect{startx}y$$mainrect{starty}];
my $vr = $mainrect;
my $hr = +{ map { $_ => $$mainrect{$_} } keys %$mainrect };
my %specialcolor = (
1 => 'cyan',
2 => 'red',
3 => 'magenta',
4 => 'yellow',
);
my $roomstyle = 1 + int rand 5;
print color $specialcolor{$roomstyle} if $debug > 3;
jot("S"); jot($roomstyle);
print color 'reset';
if ($roomstyle == 1) { # L-shaped room
my $hpinch = 1 + irr($$vr{stopx} - $$vr{startx} - 1);
jot($_) for split //, $hpinch;
if (rand(100)<= 50) {
jot("r");
$$vr{startx} += $hpinch;
} else {
jot("l");
$$vr{stopx} -= $hpinch;
}
my $vpinch = 1 + irr($$hr{stopy} - $$hr{starty} - 1);
jot($_) for split //, $vpinch;
if (rand(100)<= 50) {
jot("b");
$$hr{starty} += $vpinch;
} else {
jot("t");
$$hr{stopy} -= $vpinch;
}
} elsif ($roomstyle == 2) { # T-shaped room
if (rand(100) <= 50) {
# Vertical T
jot("v");
my $pinch = 1 + int rand(($$vr{stopx}-$$vr{startx}-1)/2);
jot($_) for split //, $pinch;
$$vr{startx} += $pinch;
$$vr{stopx} -= $pinch;
my $lift = 1 + irr(abs($$hr{stopy} - $$hr{starty} - 1));
if (rand(100) <= 50) { # Rightside-up T
jot("t");
$$hr{starty} += $lift;
} else { # Upside-down T
jot("b");
$$hr{stopy} -= $lift;
}
jot($_) for split //, $lift;
} else {
# Horizontal |- or -|
jot("h");
my $pinch = 1 + int rand(($$hr{stopy}-$$hr{starty}-1)/2);
jot($_) for split //, $pinch;
$$hr{starty} += $pinch;
$$hr{stopy} -= $pinch;
my $lift = 1 + irr(abs($$vr{stopx} - $$vr{startx} - 1));
if (rand(100) <= 50) {
jot("r");
$$vr{startx} += $lift;
} else {
jot("l");
$$vr{stopx} -= $lift;
}
jot($_) for split //, $lift;
}
} elsif ($roomstyle == 3) { # Cross-shaped room
jot("+");
my $vpinch = 1+int rand(($$vr{stopx}-$$vr{startx}-1)/2);
$$vr{startx} += $vpinch;
$$vr{stopx} -= $vpinch;
my $hpinch = 1+int rand(($$hr{stopy}-$$hr{starty}-1)/2);
$$hr{starty} += $hpinch;
$$hr{stopy} -= $hpinch;
jot($_) for split //, $vpinch;
jot(",");
jot($_) for split //, $hpinch;
} elsif ($roomstyle == 4) {
# What do you call that other Tetris piece?
my $vpinch = 1+int rand(abs($$vr{stopx}-$$vr{startx}-1)/2);
my $hpinch = 1+int rand(abs($$hr{stopy}-$$hr{starty}-1)/2);
jot($_) for split //, $vpinch;
jot(",");
jot($_) for split //, $hpinch;
if (rand(100) <= 50) {
# pinch the lower left and upper right
jot("a");
$$vr{stopx} -= $hpinch;
$$vr{stopy} -= $vpinch;
$$hr{startx} += $hpinch;
$$hr{starty} += $vpinch;
while ($$vr{stopy} <= $$hr{starty}) {
$$vr{stopy}++;
$$hr{starty}--;
}
} else {
# pinch the upper left and lower right
jot("b");
$$vr{startx} += $hpinch;
$$vr{stopy} -= $vpinch;
$$hr{stopx} -= $hpinch;
$$hr{starty} += $vpinch;
while ($$vr{stopy} <= $$hr{starty}) {
$$vr{stopy}++;
$$hr{starty}--;
}
}
} else { # roomstyle 5 is a plain rectangle
$mainrect = makeroom($mainrect);
}
if ($roomstyle <= 4) {
# We didn't call makeroom, so we have to handle
# what it would have done on our own.
# Leave room around the edge (for corridors):
leaveroomforcorridors($hr);
leaveroomforcorridors($vr);
# Fill in the walls:
makewalls($hr);
local $wallcolor = $specialcolor{$roomstyle}
if $debug > 3;
makewalls($vr);
# Now fill in the floor, right overtop of any walls
# that would otherwise run through it:
makefloor($hr);
local $floorcolor = $specialcolor{$roomstyle}
if $debug > 3;
makefloor($vr);
}
push @room, $mainrect;
} else {
jot("u");
}
}
print "\n\n";
printlevel();
print "\n\n";
}
sub layout_overlapping_rooms {
my $avgwidth = ($minroomwidth + $maxroomwidth) / 2;
my $avgheight = ($minroomheight + $maxroomheight) / 2;
my $numofrooms = ($maxcols / $avgwidth)
* ($maxrows / $avgheight);
$numofrooms = int(
($numofrooms / 3)
+ rand($numofrooms / 3)
);
for (1 .. $numofrooms) {
my $targetwidth = $minroomwidth
+ int rand ($maxroomwidth - $minroomwidth);
my $targetheight = $minroomheight
+ int rand ($maxroomheight - $minroomheight);
my $rect = randomrect($targetheight, $targetwidth);
push @room, makeroom($rect);
}
# makeroom() assumed no overlap, so we need to fix
# up a few things. We can assume the floor is in place,
# but walls may have been lost, so we must restore them:
for my $room (@room) {
# Restore Vertical Boundaries:
for my $y (($$room{starty} - 1) .. ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
}}}
# Restore Horizontal Boundaries:
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
}}}
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
}}}
# Restore Corners:
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
}}}
## if (($$room{starty} >= 1) and ($$room{startx} >= 1)) {
## $pos[$$room{starty} - 1][$$room{startx} - 1]{char}
## = $nwcornerchar;
## $pos[$$room{starty} - 1][$$room{startx} - 1]{crnr} = 1;
## }
## if (($$room{starty} >= 1) and ($$room{stopx}+1 < $maxcols)) {
## $pos[$$room{starty} - 1][$$room{stopx} + 1]{char}
## = $necornerchar;
## $pos[$$room{starty} - 1][$$room{stopx} + 1]{crnr} = 1;
## }
## if (($$room{stopy} + 1 < $maxrows) and
## ($$room{stopx} + 1 < $maxcols)) {
## $pos[$$room{stopy} + 1][$$room{stopx} + 1]{char}
## = $secornerchar;
## $pos[$$room{stopy} + 1][$$room{stopx} + 1]{crnr} = 1;
## }
## if (($$room{stopy}+1 < $maxrows) and ($$room{startx} >= 1)) {
## $pos[$$room{stopy}+1][$$room{startx} - 1]{char}
## = $swcornerchar;
## $pos[$$room{stopy} + 1][$$room{startx} - 1]{crnr} = 1;
## }
# Where there are more than two parallel walls, we
# want to put floor in the middle...
for my $y (1 .. ($maxrows - 2)) {
for my $x (1 .. ($maxcols - 2)) {
# Horizontal parallel walls (more likely):
if (($pos[$y - 1][$x]{terr} eq 'wall') and
($pos[$y][$x]{terr} eq 'wall') and
($pos[$y + 1][$x]{terr} eq 'wall') and
($pos[$y - 1][$x]{char} eq $horizwallchar) and
($pos[$y][$x]{char} eq $horizwallchar)) {
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}
# Vertical parallel walls (also possible):
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}
if (($pos[$y][$x - 1]{terr} eq 'wall') and
($pos[$y][$x]{terr} eq 'wall') and
($pos[$y][$x + 1]{terr} eq 'wall') and
($pos[$y][$x - 1]{char} eq $vertwallchar) and
($pos[$y][$x]{char} eq $vertwallchar)) {
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}
}}
# Other fixup would go here, if needed, but I think that
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}
}}
# might just about cover it.
}
}
sub layout_dense_rooms {
my $targetwidth = $maxroomwidth;
my $targetheight = $maxroomheight;
my $availtiles = $maxrows * $maxcols;
my ($iteration, $totaliteration);
my $targetheight = $maxroomheight;
my $availtiles = $maxrows * $maxcols;
while (($targetwidth >= $minroomwidth) and
($targetheight >= $minroomheight) and
($availtiles >= ($minroomwidth *
$minroomheight * 10))) {
my $height = ($targetheight > 3)
my $width = ($targetwidth > 5)
? $targetwidth - irr($targetwidth) : $targetwidth;
my $rect = randomrect($height, $width);
if (rectavailable($rect)) {
jot("+", 0);
push @room, makeroom($rect);
#use Data::Dumper; print Dumper(+{ room => \@room });
printlevel() if $debug > 3;
}
my $fitratio = int($availtiles * 5
/ ($targetwidth * $targetheight));
if ($iteration++ > $fitratio) {
# We've tried enough times at this size. Decrease size.
my $aspectratio = $targetwidth / $targetheight;
if (rand(100) <= (20 * $aspectratio)) {
$targetwidth -= (1 + int rand ($targetwidth /
$widthdivisor));
jot($_, 2) for split //, "W$targetwidth";
} else {
$targetheight -= (1 + int rand ($targetheight /
$heightdivisor));
jot($_, 2) for split //, "H$targetheight";
}
jot(" ");
$totaliteration += $iteration;
$iteration = 0;
} else {
jot();
}
}
}
if (rectavailable($rect)) {
jot("+", 0);
push @room, makeroom($rect);
#use Data::Dumper; print Dumper(+{ room => \@room });
printlevel() if $debug > 3;
}
my $fitratio = int($availtiles * 5
/ ($targetwidth * $targetheight));
if ($iteration++ > $fitratio) {
# We've tried enough times at this size. Decrease size.
my $aspectratio = $targetwidth / $targetheight;
if (rand(100) <= (20 * $aspectratio)) {
$targetwidth -= (1 + int rand ($targetwidth /
$widthdivisor));
jot($_, 2) for split //, "W$targetwidth";
} else {
$targetheight -= (1 + int rand ($targetheight /
$heightdivisor));
jot($_, 2) for split //, "H$targetheight";
}
jot(" ");
$totaliteration += $iteration;
$iteration = 0;
} else {
jot();
}
}
}
sub printlevel {
print color 'reset';
print "\n
Layout Style: $layoutstyle ($layoutname{$layoutstyle})\n\n";
print color 'reset';
print "\n
for my $row (@pos) {
for my $cell (@$row) {
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
#} elsif ($$cell{objs}) { # TODO
} else {
print color $$cell{colr} if $$cell{colr};
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
sub jot {
my ($char, $mindebuglevel) = @_;
$char ||= '.';
$mindebuglevel ||= 1;
if ($mindebuglevel + 3 <= $debug) {
for my $cell (@$row) {
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
#} elsif ($$cell{objs}) { # TODO
} else {
print color $$cell{colr} if $$cell{colr};
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
sub jot {
my ($char, $mindebuglevel) = @_;
$char ||= '.';
$mindebuglevel ||= 1;
print $char;
if (not ($jotcount++ % 60)) {
print "\n";
}
}
}
sub randomrect {
my ($theight, $twidth) = @_;
my $maxy = $maxrows - $theight - 1;
my $maxx = $maxcols - $twidth - 1;
my $starty = 1 + int rand $maxy;
my $startx = 1 + int rand $maxx;
return +{
starty => $starty,
startx => $startx,
stopy => $starty + $theight - 1,
stopx => $startx + $twidth - 1,
};
}
sub rectavailable {
my ($rect) = @_;
for my $y ($$rect{starty} .. $$rect{stopy}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
if (defined $pos[$y][$x]{room}) {
return;
} elsif (not ($pos[$y][$x]{terr} =~ /default/)) {
return;
}
}
}
return $rect;
}
sub makeroom {
my ($room, %arg) = @_;
if (not ($jotcount++ % 60)) {
print "\n";
}
}
}
sub randomrect {
my ($theight, $twidth) = @_;
my $maxy = $maxrows - $theight - 1;
my $maxx = $maxcols - $twidth - 1;
my $starty = 1 + int rand $maxy;
my $startx = 1 + int rand $maxx;
return +{
starty => $starty,
startx => $startx,
stopy => $starty + $theight - 1,
stopx => $startx + $twidth - 1,
};
}
sub rectavailable {
my ($rect) = @_;
for my $y ($$rect{starty} .. $$rect{stopy}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
if (defined $pos[$y][$x]{room}) {
return;
} elsif (not ($pos[$y][$x]{terr} =~ /default/)) {
return;
}
}
}
return $rect;
}
sub makeroom {
$$room{room} = ++$roomnum;
makefloor($room);
leaveroomforcorridors($room);
makewalls($room);
return $room;
}
sub makefloor {
my ($room) = @_;
for my $y ($$room{starty} .. $$room{stopy}) {
for my $x ($$room{startx} .. $$room{stopx}) {
$pos[$y][$x]{room} = $roomnum;
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}}
return $room;
for my $x ($$room{startx} .. $$room{stopx}) {
$pos[$y][$x]{room} = $roomnum;
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}}
}
sub makewalls {
my ($room) = @_;
# Horizontal Boundaries:
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $$room{room};
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
}}}
# Vertical Boundaries:
for my $y (($$room{starty} - 1) .. ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $$room{room};
# Vertical Boundaries:
for my $y (($$room{starty} - 1) .. ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
}
}
}
# Corners:
if (($$room{starty} >= 1) and ($$room{startx} >= 1)) {
$pos[$$room{starty} - 1][$$room{startx} - 1]{char}
= $nwcornerchar;
$pos[$$room{starty} - 1][$$room{startx} - 1]{crnr} = 1;
}
if (($$room{starty} >= 1) and ($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{starty} - 1][$$room{stopx} + 1]{char}
= $necornerchar;
$pos[$$room{starty} - 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and
($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{char}
= $secornerchar;
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and ($$room{startx} >= 1)) {
$pos[$$room{stopy} + 1][$$room{startx} - 1]{char}
= $swcornerchar;
$pos[$$room{stopy} + 1][$$room{startx} - 1]{crnr} = 1;
}
return $room;
}
sub leaveroomforcorridors {
}
}
# Corners:
if (($$room{starty} >= 1) and ($$room{startx} >= 1)) {
$pos[$$room{starty} - 1][$$room{startx} - 1]{char}
= $nwcornerchar;
$pos[$$room{starty} - 1][$$room{startx} - 1]{crnr} = 1;
}
if (($$room{starty} >= 1) and ($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{starty} - 1][$$room{stopx} + 1]{char}
= $necornerchar;
$pos[$$room{starty} - 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and
($$room{stopx} + 1 < $maxcols)) {
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{char}
= $secornerchar;
$pos[$$room{stopy} + 1][$$room{stopx} + 1]{crnr} = 1;
}
if (($$room{stopy} + 1 < $maxrows) and ($$room{startx} >= 1)) {
$pos[$$room{stopy} + 1][$$room{startx} - 1]{char}
= $swcornerchar;
$pos[$$room{stopy} + 1][$$room{startx} - 1]{crnr} = 1;
}
return $room;
}
my ($room) = @_;
# Leave room for horizontal corridors:
for my $y (($$room{starty} - 2), ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2) .. ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}}}
for my $y (($$room{starty} - 2), ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2) .. ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}}}
# Leave room for vertical corridors:
for my $y (($$room{starty} - 2) .. ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2), ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}}}
for my $y (($$room{starty} - 2) .. ($$room{stopy} + 2)) {
for my $x (($$room{startx} - 2), ($$room{stopx} + 2)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'rock';
}}}
my ($num) = @_;
return int rand rand $num;
}
Benjamin A. Schmit
Dec 6, 2012, 5:34:24 AM12/6/12
to
That does give some interesting maps… Some of the levels look more like
densely packed corridors to me, though. Guess the corridor generation
code is not yet perfect.
A (somewhat extreme) example – the corridors look as if applied
completely at random:
> ## ### ## # ## # # # # ### # ## # ### # # ## # # ## #
> # #### ### # # # # ### ## #### # #/-----\ ## ## ## ##
> # /--------------\## # #/-/------\ #/-|.....|-\ ## ## ## ###
> ### |..............| # |........|##|.........|# ##### # #
> # |..............|#### ##|........|##|.........| ## # # #
> # #|..............| # |........| |.........| ## # ### # #
> ### |..............|## ####|........|##\-|.....|-/ ##/--------\
> ## |..............| # ## \-|......| #\-----/ # # |........|
> # #\--------------/ ## ###\------/ #### ### ## |........|
> # ## ## ### # ## #/---------------\# # # ### |........|
> ###/----------\### ## #|...............|\ # # |........|#
> ##/|..........| #### |................|## ## # # \--------/
> |...........| # |................|## # # # #### #
> |...........| # # ## |................| ## # # ## ##
> |...........|# # # |................| #### ## #//---\\ ##
> |...........|# ### ##\---------------//# ### # ##|.....| #
> \\----------/# # # /-----\ # # # # # # ##|.....| ## #
> ## # # ##/----------\ #/-|.....|-\# #### ## # |.....| # #
> # # # # |..........|# |.........| ##### ### # \|...|/## ##
> ## ## # #|..........|##\-|.....|-/ /-----\## ##\---/# # #
> # # #|..........|# # \-----/## /-|.....| # ### ####
> # # # #|..........|# # ### ## |.......|# # # # # # #
> #### # # |..........| ## ## # ## # |.......| # ## # ## #
> # ## \----------/#### # # ##\-\-----/# ## # # # ##
Another quick idea: I'd create a check function which returns true if
the two given rooms are connected, either directly or indirectly through
other rooms. Then start generating random corridors between rooms, but
only where the connection function still returns false. If there are no
more unconnected pairs (i.e. every room is connected to every other room
in some way), create up to n more corridors for redundancy. Possibly
relate n to the number of corridors and rooms created already.
Benjamin
densely packed corridors to me, though. Guess the corridor generation
code is not yet perfect.
A (somewhat extreme) example – the corridors look as if applied
completely at random:
> ## ### ## # ## # # # # ### # ## # ### # # ## # # ## #
> # #### ### # # # # ### ## #### # #/-----\ ## ## ## ##
> # /--------------\## # #/-/------\ #/-|.....|-\ ## ## ## ###
> ### |..............| # |........|##|.........|# ##### # #
> # |..............|#### ##|........|##|.........| ## # # #
> # #|..............| # |........| |.........| ## # ### # #
> ### |..............|## ####|........|##\-|.....|-/ ##/--------\
> ## |..............| # ## \-|......| #\-----/ # # |........|
> # #\--------------/ ## ###\------/ #### ### ## |........|
> # ## ## ### # ## #/---------------\# # # ### |........|
> ###/----------\### ## #|...............|\ # # |........|#
> ##/|..........| #### |................|## ## # # \--------/
> |...........| # |................|## # # # #### #
> |...........| # # ## |................| ## # # ## ##
> |...........|# # # |................| #### ## #//---\\ ##
> |...........|# ### ##\---------------//# ### # ##|.....| #
> \\----------/# # # /-----\ # # # # # # ##|.....| ## #
> ## # # ##/----------\ #/-|.....|-\# #### ## # |.....| # #
> # # # # |..........|# |.........| ##### ### # \|...|/## ##
> ## ## # #|..........|##\-|.....|-/ /-----\## ##\---/# # #
> # # #|..........|# # \-----/## /-|.....| # ### ####
> # # # #|..........|# # ### ## |.......|# # # # # # #
> #### # # |..........| ## ## # ## # |.......| # ## # ## #
> # ## \----------/#### # # ##\-\-----/# ## # # # ##
Another quick idea: I'd create a check function which returns true if
the two given rooms are connected, either directly or indirectly through
other rooms. Then start generating random corridors between rooms, but
only where the connection function still returns false. If there are no
more unconnected pairs (i.e. every room is connected to every other room
in some way), create up to n more corridors for redundancy. Possibly
relate n to the number of corridors and rooms created already.
Benjamin
Jonadab the Unsightly One
Dec 6, 2012, 10:35:07 PM12/6/12
to
On Dec 6, 5:34 am, "Benjamin A. Schmit" <benjamin.sch...@gmail.com>
wrote:
percentdugout. If you specify percentdugout 1 on
the command line, you'll get almost none of that
(but you will still get corridors). (If you want to see
what's going on more clearly, e.g., while tweaking
the code or the numbers, set dugcolor to some
color clearly visibly different from corridorcolor.)
> Another quick idea: I'd create a check function
> which returns true if the two given rooms are
> connected, either directly or indirectly through
> other rooms.
That could be done. Actually, it'd be two
functions, I think: one that returns true
only if they're connected directly and a
second function that calls the first function
repeatedly in order to determine whether
there are any connections at all, including
indirect ones via other rooms. It's easy
to come up with a grossly inefficient
algorithm for this (like, n squared or
worse), which may nonetheless be good
enough given the relatively small number
of rooms (due to the draconian limits on
level map size that NetHack imposes in
order to ensure that they can fit all on
the screen at once even on a traditional
text-mode tty).
> Then start generating random corridors
> between rooms, but only where the connection
> function still returns false.
Hmm...
I will think about this.
wrote:
> Some of the levels look more like densely packed
> corridors to me, though. Guess the corridor generation
> code is not yet perfect. A (somewhat extreme) example
> – the corridors look as if applied completely at random:
Actually, that's a deliberate feature, controlled via
> corridors to me, though. Guess the corridor generation
> code is not yet perfect. A (somewhat extreme) example
> – the corridors look as if applied completely at random:
percentdugout. If you specify percentdugout 1 on
the command line, you'll get almost none of that
(but you will still get corridors). (If you want to see
what's going on more clearly, e.g., while tweaking
the code or the numbers, set dugcolor to some
color clearly visibly different from corridorcolor.)
> Another quick idea: I'd create a check function
> which returns true if the two given rooms are
> connected, either directly or indirectly through
> other rooms.
functions, I think: one that returns true
only if they're connected directly and a
second function that calls the first function
repeatedly in order to determine whether
there are any connections at all, including
indirect ones via other rooms. It's easy
to come up with a grossly inefficient
algorithm for this (like, n squared or
worse), which may nonetheless be good
enough given the relatively small number
of rooms (due to the draconian limits on
level map size that NetHack imposes in
order to ensure that they can fit all on
the screen at once even on a traditional
text-mode tty).
> Then start generating random corridors
> between rooms, but only where the connection
> function still returns false.
I will think about this.
Jonadab the Unsightly One
Dec 15, 2012, 5:25:43 PM12/15/12
to
#!/usr/bin/perl
# -*- cperl -*-
# -*- cperl -*-
# This is a Perl program that generates the following
# proposed new types of NetHack level styles:
# 1. levels consisting mostly of densely packed rooms of
# varying sizes, per Benjamin Schmit's suggestion
# proposed new types of NetHack level styles:
# 1. levels consisting mostly of densely packed rooms of
# varying sizes, per Benjamin Schmit's suggestion
# 2. levels containing rectangular rooms that may overlap,
# resulting in extra walls partitioning them into sections
# resulting in extra walls partitioning them into sections
# 3. levels containing possibly non-rectangular rooms
# (L-shaped, T-shaped, cross-shaped, etc.)
# These are connected via corridors generated in one
# of four ways:
# 1. Haphazard - corridors can leave a room in any direction
# 2. Systematic - corridors try to leave each room in each
# direction (except at the level edges)
# 3. Directed - corridors are aimed from one room to another
# 4. Hybrid - a mixture of the above styles
# 5. None - no corridors are generated
# In some cases portions of the level rock may also be
# "dug out" ahead of time.
# This is all strictly experimental, and of course this Perl
# code will not integrate into NetHack, so in order to be
# used it would need to be reimplemented in C and integrated
# into NetHack's existing level-generation code.
# If implemented, these types of levels could be used in
# custom dungeon content, in special levels (e.g., quest
# filler levels for proposed new roles), and potentially
# in Gehennom to replace some of the maze levels.
# Note that these levels should NOT be used very early in
# the dungeons, because they may contain disconnected areas
# that can only be reached by digging or teleport, as well
# as water and/or lava that may need to be traversed in some
# cases. Also, the special rooms contain monsters that a
# pre-quest, pre-castle character should not have to face.
# In other words, these are strictly late-game levels.
# Don't worry if the choices of monsters seem odd. Except
# for special rooms, this script does not attempt realistic
# monster generation, because the intention is that the
# existing monster generation code be used. So while this
# script does pepper the levels with random monsters, that's
# just so they don't look totally bare.
# Other than that, there are still a few bugs to work out
# but I think it's reached the point where it's worth
# soliciting feedback...
# If the idea of new kinds of levels to mix in with the
# mazes in Gehennom interests you, please run this Perl
# script a few times and let me know what you think.
# Specific suggestions are welcome.
use strict;
# soliciting feedback...
# If the idea of new kinds of levels to mix in with the
# mazes in Gehennom interests you, please run this Perl
# script a few times and let me know what you think.
# Specific suggestions are welcome.
my %arg = @ARGV;
my $debug = $arg{debug} || 3;
my $debug = $arg{debug} || 3;
my $layoutstyle = $arg{layoutstyle} || 1 + int rand 3;
my $corridorstyle = $arg{corridorstyle} || 1 + irr(5);
my $maxrows = $arg{maxrows} || 24;
my $maxcols = $arg{maxcols} || 65 + int rand(4);
my $maxcols = $arg{maxcols} || 65 + int rand(4);
my $maxroomwidth = $arg{maxroomwidth} || int($maxcols *
(0.2 + rand 0.25));
my $maxroomheight = $arg{maxroomheight} || int($maxrows *
(0.15 + rand 0.15));
my $minroomwidth = $arg{minroomwidth} || 2;# + int rand(2);
(0.2 + rand 0.25));
my $maxroomheight = $arg{maxroomheight} || int($maxrows *
(0.15 + rand 0.15));
my $minroomheight = $arg{minroomheight} || 2;# + int rand(1);
my $secretprob = $arg{secretprob} || 30;
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $percentdugout = $arg{percentdugout} || (irr(100)<30)?0:irr(90);
my $blankchar = $arg{blankchar} || ' ';
my $corridorchar = $arg{corridorchar} || '#';
my $dugchar = $arg{dugchar} || $corridorchar;
my $dugcolor = $arg{dugcolor} || 'white';
my $dugcolor = $arg{dugcolor} || 'white';
my $floorchar = $arg{floorchar} || '.';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $nwcornerchar = $arg{nwcornerchar} || '/';
my $horizwallchar = $arg{horizwallchar} || '-';
my $vertwallchar = $arg{vertwallchar} || '|';
my $doorchar = $arg{doorchar} || '+';
my $sdoorchar = $arg{sdoorchar} || '+';
my $necornerchar = $arg{necornerchar} || "\\";
my $swcornerchar = $arg{swcornerchar} || "\\";
my $secornerchar = $arg{secornerchar} || '/';
my $errorchar = $arg{errorchar} || 'E';
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
# The next two are NOT lexical, so that they can be dynamic
my $errorcolor = $arg{errorcolor} || 'bold yellow on_red';
# (to make certain things easier to see while tweaking).
our $wallcolor = $arg{wallcolor} || 'white on_black';
our $floorcolor = $arg{floorcolor} || 'reset';
my $doorcolor = $arg{doorcolor} || 'yellow on_black';
my $sdoorcolor = $arg{sdoorcolor} || $wallcolor;
my $corridorcolor = $arg{corridorcolor} || 'reset';
my $corridorfreq = $arg{corridorfreq} || 2 + int rand 2;
my $corridortwist = $arg{corridortwist} || 6 + irr(12);
my $sdoorcolor = $arg{sdoorcolor} || $wallcolor;
my $corridorcolor = $arg{corridorcolor} || 'reset';
my $corridorfreq = $arg{corridorfreq} || 2 + int rand 2;
my $corridorcross = $arg{corridorcross} || 35 + rand 30;
my $allcorridors = $arg{allcorridors} || 1;
my $jaggedcorr = $arg{jaggedcorr} || 10 + rand 80;
my $maxcorrlength = $arg{maxcorrlength} || $maxrows + $maxcols*1.5;
my $connectretry = $arg{connectretry} || 3;
my $widthdivisor = $arg{widthdivisor} || 2;
my $heightdivisor = $arg{heightdivisor} || 2;
my $roomnum = 0;
my $jotcount = 0;
my @room;
my %layoutname = (
1 => 'Dense Room Packing',
2 => 'Overlapping Rectangles',
3 => 'Non-Rectangular Rooms',
);
my %corrname = (
my $heightdivisor = $arg{heightdivisor} || 2;
my $roomnum = 0;
my $jotcount = 0;
my @room;
my %layoutname = (
1 => 'Dense Room Packing',
2 => 'Overlapping Rectangles',
3 => 'Non-Rectangular Rooms',
);
1 => 'Haphazard',
2 => 'Systematic',
3 => 'Directed',
4 => 'Hybrid',
5 => 'None',
);
my @randcolor = ('cyan', 'blue', 'green', 'red', 'magenta',
'bold black', 'bold cyan', 'bold blue',
'bold green', 'bold red', 'bold yellow',
'bold magenta', 'bold white'
);
my @randcolor = ('cyan', 'blue', 'green', 'red', 'magenta',
'bold black', 'bold cyan', 'bold blue',
'bold green', 'bold red', 'bold yellow',
'bold magenta', 'bold white'
);
floor => 1, stairs => 1, lava => 1,
altar => 1, statue => 1, pool => 1,
grave => 1, fountain => 1, sink => 1,
tree => 1,
);
$|=1;
use Term::ANSIColor;
use Carp;
$|=1;
use Term::ANSIColor;
my @pos = map {
my $y = $_ - 1;
[ map {
my $x = $_ - 1;
my $dug = (rand(100)<=$percentdugout) ? 1 : 0;
+{
posy => $y,
posx => $x,
char => $dug ? $dugchar : $blankchar,
room => undef,
colr => $dug ? $dugcolor : 'reset',
furn => [],
objs => [],
mons => undef,
objs => [],
mons => undef,
};
} 1 .. $maxcols ];
} 1 .. $maxrows;
print "Using layout style $layoutstyle.\n";
} 1 .. $maxcols ];
} 1 .. $maxrows;
if ($layoutstyle == 1) {
layout_dense_rooms();
} elsif ($layoutstyle == 2) {
layout_overlapping_rooms();
} elsif ($layoutstyle == 3) {
layout_non_rectangular_rooms();
} else {
die "Unknown layout style: $layoutstyle";
}
# Put stuff in the rooms...
my ($didup, $diddown) = (0, 0);
my ($fountcount, $sinkcount, $altarcount, $gravecount,
$poolcount, $lavacount) = (0, 0, 0, 0, 0, 0);
for my $room (map { $$_[0]
my ($fountcount, $sinkcount, $altarcount, $gravecount,
$poolcount, $lavacount) = (0, 0, 0, 0, 0, 0);
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
jot($_) for split //, " R$$room{room}";
} @room) {
jot($_) for split //, " R$$room{room}";
my ($roomfountcount, $roomsinkcount,
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
$roompoolcount, $roomlavacount) = (0, 0, 0, 0);
my $special;
if (not $didup) {
if (not $didup) {
$didup = placefurniture($room, 'stairs',
'<', $upstaircolor);
jot("<") if $debug > 5;
} elsif (not $diddown) {
'<', $upstaircolor);
jot("<") if $debug > 5;
$diddown = placefurniture($room, 'stairs',
'>', $downstaircolor);
jot(">") if $debug > 5;
'>', $downstaircolor);
jot(">") if $debug > 5;
} else {
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
if (rand(100)<=$specialprob) {
$special = 'statue hall'; # Default
jot("S") if $debug > 5;
if (rand(100)<=40) {
$special = 'dragon lair';
jot("D") if $debug > 6;
} elsif (rand(100)<=50) {
$special = 'garden of temptation';
jot("G") if $debug > 6;
if (rand(100)<=40) {
$special = 'dragon lair';
jot("D") if $debug > 6;
} elsif (rand(100)<=50) {
$special = 'garden of temptation';
jot("G") if $debug > 6;
} # TODO: more special-room options
}}
if ($special eq 'statue hall') {
my @bordertile;
my $statuecount;
push @bordertile, $_ for map {
my $x = $_;
}}
if ($special eq 'statue hall') {
my @bordertile;
my $statuecount;
push @bordertile, $_ for map {
my $x = $_;
[$$room{starty}, $x]
} $$room{startx} .. $$room{stopx};
} $$room{startx} .. $$room{stopx};
push @bordertile, $_ for map {
my $y = $_;
[$y, $$room{stopx}]
my $y = $_;
} (($$room{starty} + 1) .. ($$room{stopy} - 1));
push @bordertile, $_ for map {
my $x = $_;
[$$room{stopy}, $x]
} reverse ($$room{startx} .. $$room{stopx});
[$$room{stopy}, $x]
} reverse ($$room{startx} .. $$room{stopx});
push @bordertile, $_ for map {
my $y = $_;
my $y = $_;
[$y, $$room{startx}]
} reverse (($$room{starty} + 1) .. ($$room{stopy} - 1));
} reverse (($$room{starty} + 1) .. ($$room{stopy} - 1));
my $spacing = (defined $statuespacing)
? $statuespacing : ((int rand(5)) ? 1 : rand(3));
while (scalar @bordertile) {
my $tile = shift @bordertile;
placefurniture($room, 'statue', $statuechar,
? $statuespacing : ((int rand(5)) ? 1 : rand(3));
while (scalar @bordertile) {
my $tile = shift @bordertile;
$statuecolor, @$tile);
for (1 .. $spacing) {
shift @bordertile if scalar @bordertile;
}}
# TODO: also place some traps in the room.
} elsif ($special eq 'dragon lair') {
my %dragoncolor = (black => 'bold black',
red => 'bold red',
blue => 'blue',
gray => 'white');
my @color = keys %dragoncolor;
my $color = $color[rand @color];
placemonster($room, "great $color dragon",
for (1 .. $spacing) {
shift @bordertile if scalar @bordertile;
}}
# TODO: also place some traps in the room.
} elsif ($special eq 'dragon lair') {
my %dragoncolor = (black => 'bold black',
red => 'bold red',
blue => 'blue',
gray => 'white');
my @color = keys %dragoncolor;
my $color = $color[rand @color];
'D', $dragoncolor{$color});
placemonster($room, "$color dragon",
'D', $dragoncolor{$color})
for 1 .. (2 + int rand 3);
placemonster($room, "baby $color dragon",
for 1 .. (2 + int rand 3);
'D', $dragoncolor{$color})
for 1 .. (3 + int rand 4);
# TODO: place gold and gems and thematic stuff
#} elsif ($special eq 'another option') { # TODO
for 1 .. (3 + int rand 4);
# TODO: place gold and gems and thematic stuff
#} elsif ($special eq 'another option') { # TODO
} elsif ($special eq 'garden of temptation') {
my @gmonst = (
my @gmonst = (
['succubus', '&', 'reset'],
['incubus', '&', 'reset'],
['incubus', '&', 'reset'],
['mountain nymph', 'n', 'yellow'],
['water nymph', 'n', 'blue'],
['wood nymph', 'n', 'green'],
);
my @gfurn = (
['tree', '#', 'green'],
['tree', '#', 'green'],
['fountain', $fountainchar, $fountaincolor],
['pool', $poolchar, $poolcolor],
);
for (1 .. 4) {
my $f = $gfurn[rand @gfurn];
my $m = $gmonst[rand @gmonst];
placefurniture($room, @$f);
placemonster($room, @$m);
placemonster($room, @$m);
}
} else {
jot("R") if $debug > 5;
['wood nymph', 'n', 'green'],
);
my @gfurn = (
['tree', '#', 'green'],
['tree', '#', 'green'],
['fountain', $fountainchar, $fountaincolor],
['pool', $poolchar, $poolcolor],
);
for (1 .. 4) {
my $f = $gfurn[rand @gfurn];
my $m = $gmonst[rand @gmonst];
placefurniture($room, @$f);
placemonster($room, @$m);
placemonster($room, @$m);
}
} else {
jot("R") if $debug > 5;
while ((rand(100) <= $fountainprob) and
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
if (placefurniture($room, 'fountain',
($fountcount < $maxfountains) and
($roomfountcount < $maxroomfounts)) {
$fountainchar, $fountaincolor)) {
$fountcount++; $roomfountcount++;
jot($fountainchar) if $debug > 6;
}}
while ((rand(100) <= $sinkprob) and
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
if (placefurniture($room, 'sink',
while ((rand(100) <= $sinkprob) and
($sinkcount < $maxsinks) and
($roomsinkcount < $maxroomsinks)) {
$sinkchar, $sinkcolor)) {
$sinkcount++; $roomsinkcount++;
jot($sinkchar) if $debug > 6;
}}
if ((rand(100) <= $altarprob) and
($altarcount < $maxaltars)) {
if (placefurniture($room, 'altar',
if ((rand(100) <= $altarprob) and
($altarcount < $maxaltars)) {
$altarchar, $altarcolor)) {
$altarcount++;
jot($altarchar) if $debug > 6;
if (rand(100) <= $priestprob) {
placemonster($room, 'aligned priest',
$priestchar, $priestcolor);
jot($priestchar) if $debug > 6;
}}}
if ((rand(100) <= $graveprob) and
($gravecount < $maxgraves)) {
if (placefurniture($room, 'grave',
if ((rand(100) <= $graveprob) and
($gravecount < $maxgraves)) {
$gravechar, $gravecolor)) {
$gravecount++;
jot($gravechar) if $debug > 6;
}}
# Terrain Features:
while ((rand(100) <= ($roompoolcount
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
if (placefurniture($room, 'pool',
? $morepoolprob
: $poolprob))
and ($poolcount < $maxpools)
and ($roompoolcount < $maxroompools)) {
$poolchar, $poolcolor)) {
$poolcount++; $roompoolcount++;
jot($poolchar) if $debug > 6;
}}
while ((rand(100) <= ($roomlavacount
? $morelavaprob
: $lavaprob))
and ($lavacount < $maxlava)
while ((rand(100) <= ($roomlavacount
? $morelavaprob
: $lavaprob))
and ($roomlavacount < $maxroomlava)
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
if (placefurniture($room, 'lava',
and (not $roompoolcount)
and (not $roomfountcount)
and (not $roomsinkcount)) {
$lavachar, $lavacolor)) {
$lavacount++; $roomlavacount++;
jot($lavachar) if $debug > 6;
}}
my $roommonstcount = 0;
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
my $roommonstcount = 0;
while (rand(100) <= ($roommonstcount
? $moremonstprob
: $monsterprob)) {
my ($mtype, $mchar, $mcolor)
= @{$randmonst[int rand @randmonst]};
if (placemonster($room, $mtype, $mchar, $mcolor)) {
$roommonstcount++;
jot($mchar) if $debug > 6;
$roommonstcount++;
}
if (rand(100)<= $mongroupprob) {
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
if (rand(100)<= $mongroupprob) {
for (1 .. int rand $maxgroupsize) {
if ($roommonstcount <= $maxroommonst) {
if (placemonster($room, $mtype, $mchar, $mcolor)) {
$roommonstcount++;
jot("+") if $debug > 6;
}
}}}
}
# TODO: Place Objects
}
}
print "\nPlacing corridors (style $corridorstyle)...\n" if $debug;
$roommonstcount++;
jot("+") if $debug > 6;
}
}}}
}
# TODO: Place Objects
}
}
place_corridors();
printlevel();
exit 0; # ---------------- Subroutines follow --------------------
if ($corridorstyle == 1) {
place_haphazard_corridors();
} elsif ($corridorstyle == 2) {
place_systematic_corridors();
} elsif ($corridorstyle == 3) {
place_directed_corridors();
} elsif ($corridorstyle == 4) {
place_hybrid_corridors();
}
}
sub zeroorjag {
if ($jaggedcorr) {
return (rand(100)<25)
? rand(0.4)
: 0;
} else {
return 0;
}
}
sub place_systematic_corridors {
my %conn;
my @corrpos = sort {
$$a[3] <=> $$b[3]
} map {
my $r = $_; map {
my $coord = $_;
my ($yd, $xd) = @$coord;
[$r, $yd, $xd, rand(17)];
} [-1, zeroorjag()],
[ 1, zeroorjag()],
[zeroorjag(), -1],
[zeroorjag(), 1],
} @room;
my %corrconn;
while (($allcorridors > 0) and
(not all_rooms_connected(\@room, \%conn))) {
for my $cp (@corrpos) {
my $cwanted = $corridorfreq;
#$cwanted = int($cwanted * 1.75) if $layoutstyle == 2;
$cwanted = 1 + int rand (int(($cwanted + 3) / 4));
my ($room, $ydir, $xdir) = @$cp;
$cwanted = 0 if ($$room{startx} < 2 and $xdir < 0);
$cwanted = 0 if ($$room{starty} < 2 and $ydir < 0);
$cwanted = 0 if ($$room{stopx} + 2 >= $maxcols
and $xdir > 0);
$cwanted = 0 if ($$room{stopy} + 2 >= $maxrows
and $ydir > 0);
jot($_) for split //, " R$$room{room}<$ydir,$xdir>"
. "CW$cwanted ";
my (@conn, $attempt);
while (($cwanted > scalar @conn) and ($attempt < 3)) {
jot("-"); jot($_) for split //, $attempt;
my $corridorlength = 0;
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my $connected = 0;
my ($y, $x, $realy, $realx) = point_within_room($room);
if ($debug > 7) {
$pos[$y][$x]{colr} = 'bold cyan';
$pos[$y][$x]{char} = ($$room{room} % 10);
}
while ($pos[$y][$x]{room} == $$room{room}) {
if ($pos[$y][$x]{terr} eq 'floor') {
jot($floorchar);
} elsif ($pos[$y][$x]{terr} eq 'wall') {
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} = $secret?$sdoorchar: $doorchar;
$pos[$y][$x]{colr} = $secret?$sdoorcolor: $doorcolor;
jot($doorchar);
} elsif ($pos[$y][$x]{terr} eq 'door') {
jot($doorchar);
} else {
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
jot($corridorchar);
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
}
$realx += $xdir; $x = int $realx;
$realy += $ydir; $y = int $realy;
} # That just gets us out of our starting room.
# Now we can build the corridor until it connects
# to something somewhere...
while (not $connected) {
my $loopcount = 0;
$corrconn{$y}{$x}{$$room{room}} = 1;
if ($pos[$y][$x]{terr} eq 'wall') {
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} = $secret?$sdoorchar: $doorchar;
$pos[$y][$x]{colr} = $secret?$sdoorcolor: $doorcolor;
jot($doorchar);
} elsif ($pos[$y][$x]{terr} eq 'door') {
jot($doorchar);
} elsif ($connectible{$pos[$y][$x]{terr}}) {
jot($floorchar);
if ($pos[$y][$x]{room} and
($pos[$y][$x]{room} ne $$room{room})) {
$connected = 1; $attempt = 0;
push @conn, $pos[$y][$x]{room};
$conn{$pos[$y][$x]{room}}{$$room{room}}++;
$conn{$$room{room}}{$pos[$y][$x]{room}}++;
use Data::Dumper; print Dumper(\%conn)
if $debug > 9;
jot($_) for split //, "C$pos[$y][$x]{room}";
printlevel() if $debug > 15;
if (all_rooms_connected(\@room, \%conn)) {
jot("A");
return if rand(15) < $corridorfreq;
}
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
jot($corridorchar);
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
my @targ = grep {
not $conn{$_}{$$room{room}}
and not ($_ == $$room{room})
} keys %{$corrconn{$y}{$x}};
if (@targ) {
jot($_), split //, "c:" . (join ",", @targ);
if (rand(100) >= $corridorcross) {
$connected = scalar @targ;
$attempt = 0;
jot("s"); # stop here
} else {
jot("c"); # continue
}
push @conn, $_ for @targ;
$conn{$_}{$$room{room}}++ for @targ;
$conn{$$room{room}}{$_}++ for @targ;
use Data::Dumper; print Dumper(\%conn)
if $debug > 9;
}
} elsif ($pos[$y][$x]{terr} =~ /rock|default/) {
jot("#") if $debug > 8;
} elsif ($pos[$y][$x]{terr} =~ /rock|default/) {
jot("#") if $debug > 8;
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = ($debug > 12)
? ("" . $corridorlength % 10)
: $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1;
$attempt++;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1;
push @conn, 'Error' if (not $attempt % 2);
}
my $turning = 0;
my ($oldxdir, $oldydir);
if (((rand(100) <= $corridortwist)
and $corridorlength) or
(($pos[$y][$x]{terr} =~ /wall|door/) and
($pos[$y+$ydir][$x+$xdir]{terr} =~ /wall|door/))) {
($oldxdir, $oldydir) = ($xdir, $ydir);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
if (($xdir ne $oldxdir) or ($ydir ne $oldydir)) {
$ydir = int rand(3) - 1;
$pos[$y][$x]{colr} = 'bold yellow' if $debug > 9;
jot("T") if $debug > 7;
$turning = 1;
}
}
while ((($x + $xdir < 0) or
($x + $xdir >= $maxcols) or
}
while ((($x + $xdir < 0) or
($y + $ydir < 0) or
($y + $ydir >= $maxrows) or
#($pos[$y + $ydir][$x + $xdir]{crnr}) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0))
) and ($loopcount++ < 1000)) {
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0))
if ((($x + $xdir < 0) or
($x + $xdir >= $maxcols) or
($y + $ydir < 0) or
($y + $ydir >= $maxrows)
# or ($pos[$y + $ydir][$x + $xdir]{crnr})
) and not $turning) {
$pos[$y][$x]{colr} = 'bold magenta' if $debug > 9;
jot("X") if $debug > 7;
}
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
$xdir = 1 if $x < 1;
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
$ydir = 1 if $y < 1;
$xdir = -1 if $x + 1 >= $maxcols;
$ydir = -1 if $y + 1 >= $maxrows;
if (rand(100) < $jaggedcorr) {
if (rand(100) < 50) {
$ydir *= (0.5 + (0.5 * rand(1)));
} else {
$xdir *= (0.5 + (0.5 * rand(1)));
}}
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
$xdir *= -1 if (($x + $xdir < 0) or
($x + $xdir >= $maxcols));
$ydir *= -1 if (($y + $ydir < 0) or
($x + $xdir >= $maxcols));
($y + $ydir >= $maxrows));
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y + int $ydir][$x]{char} eq $blankchar) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
$pos[$y + int $ydir][$x]{terr} = 'hall';
$pos[$y + int $ydir][$x]{char} = $corridorchar;
$pos[$y + int $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x + int $xdir]{char} eq $blankchar) {
}
} else {
# Try for an adjacent tile vertically:
$pos[$y][$x + int $xdir]{terr} = 'hall';
$pos[$y][$x + int $xdir]{char} = $corridorchar;
$pos[$y][$x + int $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}}
}
if (($y + $ydir > $maxrows) or ($y + $ydir < 0)) {
}}
}
$ydir *= -1;
}
if (($x + $xdir > $maxcols) or ($x + $xdir < 0)) {
$xdir *= -1;
}
$x += $xdir;
$y += $ydir;
$x += $xdir;
$y += $ydir;
$corridorlength++ if ($xdir or $ydir);
jot("*") if $debug > 8;
if ($corridorlength > $maxcorrlength) {
$attempt++;
$connected = 1;
push @conn, 'maxl' if not $attempt % 2;
}
}
}}
jot($_) for split //, "AC:$allcorridors";
printlevel() if $debug > 4;
$allcorridors -= 1;
}
}
sub all_rooms_connected {
my ($roomlist, $conn) = @_;
defined $conn
or croak "all_rooms_connected called without conn";
my (@room) = map { $$_{room} } @$roomlist;
use Data::Dumper; print Dumper(+{
conn => $conn,
numofrooms => (scalar @room),
}) if $debug > 18;
for my $iter (@room) {
for my $roomone (@room) {
for my $roomtwo (@room) {
if ($$conn{$roomone}{$roomtwo}) {
for my $r (keys %{$$conn{$roomone}}) {
$$conn{$r}{$roomtwo} = 1;
$$conn{$roomtwo}{$r} = 1;
}}
}}}
use Data::Dumper; print Dumper(+{ conn => $conn
}) if $debug > 16;
# So now each should be marked as connected to every
# other room that it's (even indirectly) connected to.
# Thus we can just pick one and check whether it's
# connected to all the others...
my $testroom = shift @room;
for my $target (@room) {
return if not $$conn{$testroom}{$target};
}
jot($_) for split //, 'DONE';
return 'All Connected';
}
sub place_hybrid_corridors {
my @rm = grep { rand(100) <= 40 } @room;
while (@rm) {
my $roomone = shift @rm;
if (@rm) {
my $roomtwo = shift @rm;
jot($_) for split //, qq[{$$roomone{room}-$$roomtwo{room}}];
draw_corridor_between_rooms($roomone, $roomtwo);
}}
my %conn;
my %corrconn;
my %triedroom;
while (($allcorridors > 0) and
(not all_rooms_connected(\@room, \%conn))) {
if ($debug > 4) {
print "\nAllCorridors: $allcorridors\n";
print "\nConnections:\n" . (join "", map {
my $r = $room[$_];
" $$r{room} [$triedroom{$$r{room}}] "
. "($$r{starty},$$r{startx}),"
. "($$r{stopy},$$r{stopx}) => [" . (join ", ",
keys %{$conn{$$r{room}}}) . "]\n";
} 0 .. $#room) . "\n";
#use Data::Dumper; print Dumper(+{ conn => \%conn,
# allc => $allcorridors,
# });
printlevel();
}
for my $room (map { $$_[0]
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
my (@conn, %conn, $attempt);
$triedroom{$$room{room}}++;
my $cwanted = 1 + int rand $corridorfreq;
$cwanted = int($cwanted * 1.75) if $layoutstyle == 2;
if ($debug > 10) {
printlevel();
}
jot($_) for split //, " R$$room{room}CW$cwanted ";
while (($cwanted > scalar @conn) and ($attempt < 25)) {
jot("-");
if ($debug > 10) {
printlevel();
}
jot($_) for split //, " R$$room{room}CW$cwanted ";
while (($cwanted > scalar @conn) and ($attempt < 25)) {
jot("-");
my ($xdir, $ydir, $origin) = (0, 0, +{});
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my $originok = 0;
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while (($xdir == 0) and ($ydir == 0)) {
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
$ydir = (int rand(3)) - 1;
}
$origindir =
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
jot("V") if $debug > 6;
# origin must be top or bottom
jot(($ydir>0) ? "n" : "s") if $debug > 7;
$$origin{y} = ($ydir > 0)
? $$room{stopy} + 1
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
$$origin{x} = $$room{startx} + int rand $floorwidth;
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
} else {
jot("H") if $debug > 6;
# origin must be on the side
jot(($xdir>0) ? "e" : "w") if $debug > 7;
$$origin{x} = ($xdir > 0)
? $$room{stopx} + 1
: $$room{startx} - 1;
$floorheight = $$room{stopy} - $$room{starty} + 1;
$$origin{y} = $$room{starty}
+ int rand $floorheight;
: $$room{startx} - 1;
$floorheight = $$room{stopy} - $$room{starty} + 1;
$$origin{y} = $$room{starty}
}
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# Do not allow origin at map edge:
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
if ($originok) {
jot("O");
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
if ($originok) {
jot("O");
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
jot("A") if $debug > 6;
} else {
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
if ($debug > 6) {
my $color = $randcolor[rand @randcolor];
$pos[$$origin{y}][$$origin{x}]{colr} = $color;
print color $color;
jot($doorchar);
print color 'reset';
}}
my $color = $randcolor[rand @randcolor];
$pos[$$origin{y}][$$origin{x}]{colr} = $color;
print color $color;
jot($doorchar);
print color 'reset';
}}
my $y = $$origin{y};
my $x = $$origin{x};
my ($realy, $realx) = ($y, $x);
my $x = $$origin{x};
jot($_) for split //, "y$y,x$x";
my $connected = undef;
my ($oldydir, $oldxdir) = ($ydir, $xdir);
my $connected = undef;
while ((not $connected) and
($corridorlength <= $maxcorrlength)) {
jot(",") if $debug > 20;
my $loopcount = 0;
$corrconn{$y}{$x}{$$room{room}} = 1;
my $loopcount = 0;
if ((rand(100) <= $corridortwist)
and $corridorlength) {
and $corridorlength) {
($oldxdir, $oldydir) = ($xdir, $ydir);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
$ydir = int rand(3) - 1;
jot("T") if $debug > 7;
}
}
while ((($x + $xdir < 0) or
($x + $xdir >= $maxcols - 1) or
($y + $ydir < 0) or
($y + $ydir >= $maxrows - 1) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0))
#or ($pos[$y + $ydir][$x + $xdir]{crnr})
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0))
) and ($loopcount++ < 1000)) {
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
warn "!" if ($loopcount >= 500 and $debug > 4);
$ydir = int rand(3) - 1;
}
$xdir *= -1 if (($x + $xdir < 0) or
($x + $xdir >= $maxcols - 1));
$ydir *= -1 if (($y + $ydir < 0) or
($y + $ydir >= $maxrows - 1));
if (rand(100) < $jaggedcorr) {
if (rand(100) < 50) {
$ydir *= (0.5 + (0.5 * rand(1)));
} else {
$xdir *= (0.5 + (0.5 * rand(1)));
}}
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y+int $ydir][$x]{char} eq $blankchar) {
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
$pos[$y + int $ydir][$x]{terr} = 'hall';
$pos[$y + int $ydir][$x]{char} = $corridorchar;
$pos[$y + int $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x+int $xdir]{char} eq $blankchar) {
}
} else {
# Try for an adjacent tile vertically:
$pos[$y][$x + int $xdir]{terr} = 'hall';
$pos[$y][$x + int $xdir]{char} = $corridorchar;
$pos[$y][$x + int $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}}}
$realy += $ydir; $y = int $realy;
}}}
$realx += $xdir; $x = int $realx;
$corridorlength++;
jot(".") if $debug > 8;
if (($y >= $maxrows) or ($x >= $maxcols)
or ($x < 0) or ($y < 0)) {
@pos = @save;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
jot("e") if $debug > 7;
}
}
if (($pos[$y][$x]{terr} eq 'wall') or
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
jot("a") if $debug > 7;
} else {
jot($doorchar) if $debug > 7;
} else {
jot($doorchar) if $debug > 7;
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
if (not $conn{$$room{room}}{$toroom}) {
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
# We've connected to a new room.
$conn{$$room{room}}{$toroom}++;
$conn{$toroom}{$$room{room}}++;
push @conn, $toroom;
$connected = 1;
jot("*") if $debug > 6;
$connected = 1;
} else {
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe'
if not ++$attempt % $connectretry;
$connected = 1;
push @conn, 'dupe'
if not ++$attempt % $connectretry;
jot("d") if $debug > 7;
}
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
my @targ = grep {
not $conn{$_}{$$room{room}}
and not ($_ == $$room{room})
} keys %{$corrconn{$y}{$x}};
if (@targ) {
jot($_), split //, "c:" . (join ",", @targ);
if (rand(100) >= $corridorcross) {
$connected = scalar @targ;
$attempt = 0;
jot("s"); # stop here
} else {
jot("c"); # continue
}
push @conn, $_ for @targ;
$conn{$_}{$$room{room}}++ for @targ;
$conn{$$room{room}}{$_}++ for @targ;
}
#jot("f") if $debug > 6;
#push @conn, 'fail'
# if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} eq 'floor') {
$connected = 1;
jot("?") if $debug > 6;
push @conn, '????'
$connected = 1;
jot("?") if $debug > 6;
push @conn, '????'
if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} =~ /rock|default/) {
jot("#") if $debug > 8;
jot("#") if $debug > 8;
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} elsif ($connectible{$pos[$y][$x]{terr}}) {
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
$connected = 1;
jot("?") if $debug > 6;
push @conn, '????'
jot("?") if $debug > 6;
push @conn, '????'
if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} eq '') {
warn "Uninitialized terrain at ($y,$x)\n";
$connected = 1; push @conn, 'Error';
} else {
warn "Unhandled terrain type at ($y,$x): '"
. $pos[$y][$x]{terr} . "'";
$connected = 1; push @conn, 'Error';
}
}}
}}
}
$allcorridors -= 0.5;
}
}}
}}
}
}
##warn "TODO: Hybrid Corridors Not Yet Fully Implemented.\n";
##$corridorstyle = 1 + int rand 3;
##warn "Using $corrname{$corridorstyle} corridors instead.\n";
##place_corridors();
}
sub place_directed_corridors {
my @rm;
my $connperroom = 2 + irr(3);
for (1 .. $connperroom) {
push @rm, $_ for map {
$$_[0]
} sort {
$$a[1] <=> $$b[1]
} map {
[$_ => rand(7)]
} sort {
$$a[1] <=> $$b[1]
} map {
} @room;
}
while (@rm) {
my $roomone = shift @rm;
if (@rm) {
my $roomtwo = shift @rm;
if ($$roomone{room} == $$roomtwo{room}) {
# This can happen occasionally if there are an odd
# number of rooms, because the repeated shuffle
# ordering can put the same room at the end of
# one shuffle and beginning of the next shuffle.
# Here's a feeble attempt to correct it:
push @rm, $roomtwo;
$roomtwo = shift @rm;
# That should work unless the *same* room is
# back-to-back on more than one occasion, or
# back-to-back and also at the end of the list.
# But there's only so much we can do, eh?
}
draw_corridor_between_rooms($roomone, $roomtwo);
}}
}
sub point_within_room {
my ($room) = @_;
my $realx = $$room{startx}
+ rand($$room{stopx} - $$room{startx});
my $realy = $$room{starty}
+ rand($$room{stopy} - $$room{starty});
my $x = int $realx;
my $y = int $realy;
return ($y, $x, $realy, $realx);
}
sub draw_corridor_between_rooms {
my ($rone, $rtwo) = @_;
my ($yone, $xone) = point_within_room($rone);
my ($ytwo, $xtwo) = point_within_room($rtwo);
my $vdrop = abs($yone - $ytwo) || 0.1;
my $hdrop = abs($xone - $xtwo) || 0.1;
my ($ydir, $xdir, $targetlength);
if ($vdrop > $hdrop) {
# Mostly vertical with a bit of horizontal jag.
$ydir = ($ytwo > $yone) ? 1 : -1;
$xdir = $hdrop / $vdrop;
$xdir *= -1 if ($xone > $xtwo);
$targetlength = $vdrop * 2;
} else {
# Mostly horizontal with a bit of vertical jag.
$xdir = ($xtwo > $xone) ? 1 : -1;
$ydir = $vdrop / $hdrop;
$ydir *= -1 if ($yone > $ytwo);
$targetlength = $hdrop * 2;
}
#use Data::Dumper; warn Dumper(+{
# pone => [$yone, $xone],
# ptwo => [$ytwo, $xtwo],
# drop => [$vdrop, $hdrop],
# dirs => [$ydir, $xdir],
# tlen => $targetlength,
# });
my ($realy, $realx, $y, $x) = ($yone, $xone);
my $corridorlength = 0;
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
while ($corridorlength < $targetlength) {
if ($corridorlength % 2) {
$realx += $xdir; $x = int $realx;
} else {
$realy += $ydir; $y = int $realy;
}
$corridorlength++;
jot($_) for split //, "($y,$x)";
if ($pos[$y][$x]{terr} eq 'wall') {
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} = $secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} = $secret ? $sdoorcolor : $doorcolor;
jot($doorchar);
$pos[$y][$x]{char} = $secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} = $secret ? $sdoorcolor : $doorcolor;
} elsif ($pos[$y][$x]{terr} eq 'door') {
jot($doorchar);
} elsif ($connectible{$pos[$y][$x]{terr}}) {
jot($floorchar);
} elsif ($pos[$y][$x]{terr} =~ 'hall') {
jot($corridorchar);
} elsif ($pos[$y][$x]{terr} =~ 'rock|default') {
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
}
}
}
sub place_haphazard_corridors {
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
}
}
}
for my $room (map { $$_[0]
} sort { $$a[1] <=> $$b[1]
} map { [$_, rand(953)]
} @room) {
my (@conn, %conn, $attempt);
my $cwanted = 1 + int rand $corridorfreq;
$cwanted = int($cwanted * 1.75) if $layoutstyle == 2;
if ($debug > 10) {
printlevel();
}
jot($_) for split //, " R$$room{room}CW$cwanted ";
while (($cwanted > scalar @conn) and ($attempt < 25)) {
jot("-");
if ($debug > 10) {
printlevel();
}
jot($_) for split //, " R$$room{room}CW$cwanted ";
while (($cwanted > scalar @conn) and ($attempt < 25)) {
jot("-");
my ($xdir, $ydir, $origin) = (0, 0, +{});
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my $secret = (rand(100) <= $secretprob) ? 1 : 0;
my @save = @pos;
my $originok = 0;
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
my ($origindir, $origintry);
my ($floorwidth, $floorheight);
while ((not $originok) and ($origintry++ < 80)) {
while ((($xdir == 0) and ($ydir == 0))
or ($xdir and $ydir) ) {
$xdir = (int rand(3)) - 1;
$ydir = (int rand(3)) - 1;
}
$origindir =
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
(not $xdir)
? 'vert'
: (not $ydir)
? 'horz'
: (rand(100) >= 50) ? 'vert' : 'horz';
if ($origindir eq 'vert') {
jot("V") if $debug > 6;
# origin must be top or bottom
jot(($ydir>0) ? "n" : "s") if $debug > 7;
$$origin{y} = ($ydir > 0)
? $$room{stopy} + 1
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
$$origin{x} = $$room{startx} + int rand $floorwidth;
} else { jot("H") if $debug > 6;
: $$room{starty} - 1;
$floorwidth = $$room{stopx} - $$room{startx} + 1;
$$origin{x} = $$room{startx} + int rand $floorwidth;
} else { jot("H") if $debug > 6;
# origin must be on the side
jot(($xdir>0) ? "e" : "w") if $debug > 7;
$$origin{x} = ($xdir > 0)
? $$room{stopx} + 1
: $$room{startx} - 1;
$floorheight = 1+$$room{stopy} - $$room{starty};
: $$room{startx} - 1;
$$origin{y} = $$room{starty}
+ int rand $floorheight;
}
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# Is that origin OK? Note that we don't want to
# allow origin at map edge.
$originok = 1;
# Do not allow origin at map edge:
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
if ($originok) {
jot("O");
if (($$origin{x} < 2) or ($$origin{y} < 2) or
($$origin{x} + 2 >= $maxcols) or
($$origin{y} + 2 >= $maxrows)) {
$originok = 0;
}
my $corridorlength = 0;
if ($originok) {
jot("O");
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
jot("A") if $debug > 6;
} else {
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
$pos[$$origin{y}][$$origin{x}]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$$origin{y}][$$origin{x}]{colr} =
$secret ? $sdoorcolor : $doorcolor;
$pos[$$origin{y}][$$origin{x}]{terr} = 'door';
if ($debug > 6) {
my $color = $randcolor[rand @randcolor];
$pos[$$origin{y}][$$origin{x}]{colr} = $color;
print color $color;
jot($doorchar);
print color 'reset';
}}
my $color = $randcolor[rand @randcolor];
$pos[$$origin{y}][$$origin{x}]{colr} = $color;
print color $color;
jot($doorchar);
print color 'reset';
}}
my $x = $$origin{x};
my $y = $$origin{y};
my $y = $$origin{y};
jot($_) for split //, "y$y,x$x";
my $connected = undef;
my ($oldxdir, $oldydir);
while (not $connected) {
jot(",") if $debug > 20;
my $loopcount = 0;
if ((rand(100) <= $corridortwist)
and $corridorlength) {
my $connected = undef;
my ($oldxdir, $oldydir);
while (not $connected) {
jot(",") if $debug > 20;
my $loopcount = 0;
if ((rand(100) <= $corridortwist)
and $corridorlength) {
($oldxdir, $oldydir) = ($xdir, $ydir);
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
$ydir = int rand(3) - 1;
jot("T") if $debug > 7;
}
}
while ((($x + $xdir < 0) or
($x + $xdir >= $maxcols) or
($y + $ydir < 0) or
($y + $ydir >= $maxrows) or
(($xdir == 0) and ($ydir == 0)) or
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
(($oldxdir + $xdir == 0) and
($oldydir + $ydir == 0)) or
($pos[$y + $ydir][$x + $xdir]{crnr})
) and ($loopcount++ < 1000)) {
$xdir = int rand(3) - 1;
$ydir = int rand(3) - 1;
}
$ydir = int rand(3) - 1;
}
warn "!" if ($loopcount >= 1000 and $debug > 2);
$xdir *= -1 if (($x + $xdir < 0) or
($x + $xdir >= $maxcols));
$ydir *= -1 if (($y + $ydir < 0) or
($x + $xdir >= $maxcols));
($y + $ydir >= $maxrows));
if ($xdir and $ydir) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
if ($pos[$y + $ydir][$x]{char} eq $blankchar) {
# When doing diagonals, attempt to fill in
# an adjascent tile, to reduce the need for
# squeezing through tight spaces:
if (rand(100)<=60) {
# Try for an adjacent tile horizontally:
$pos[$y + $ydir][$x]{terr} = 'hall';
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
if ($pos[$y][$x + $xdir]{char} eq $blankchar) {
$pos[$y + $ydir][$x]{char} = $corridorchar;
$pos[$y + $ydir][$x]{colr} =
($debug > 9) ? 'red' : $corridorcolor;
}
} else {
# Try for an adjacent tile vertically:
$pos[$y][$x + $xdir]{terr} = 'hall';
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
$pos[$y][$x + $xdir]{char} = $corridorchar;
$pos[$y][$x + $xdir]{colr} =
($debug > 9) ? 'green' : $corridorcolor;
}
}
}
$x += $xdir;
$y += $ydir;
$y += $ydir;
$corridorlength++ if ($xdir or $ydir);
jot(".") if $debug > 8;
if (($y > $maxrows) or ($x > $maxcols)
or ($x < 0) or ($y < 0)) {
jot(".") if $debug > 8;
if (($y > $maxrows) or ($x > $maxcols)
or ($x < 0) or ($y < 0)) {
@pos = @save;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
$connected = 1;
push @conn, 'edge'
if not ++$attempt % $connectretry;
jot("e") if $debug > 7;
}
}
if (($pos[$y][$x]{terr} eq 'wall') or
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
($pos[$y][$x]{terr} eq 'door')) {
if ((($pos[$$origin{y}][$$origin{x}]{char}
eq $horizwallchar)
and (($pos[$$origin{y}][$$origin{x}-1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}-1]{char}
eq $sdoorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $doorchar) or
($pos[$$origin{y}][$$origin{x}+1]{char}
eq $sdoorchar))) or
(($pos[$$origin{y}][$$origin{x}]{char}
eq $vertwallchar)
and (($pos[$$origin{y}-1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}-1][$$origin{x}]{char}
eq $sdoorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $doorchar) or
($pos[$$origin{y}+1][$$origin{x}]{char}
eq $sdoorchar)))) {
# Already Connected Here.
jot("a") if $debug > 7;
} else {
jot($doorchar) if $debug > 7;
} else {
jot($doorchar) if $debug > 7;
$pos[$y][$x]{terr} = 'door';
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
if (not $conn{$$room{room}}{$toroom}) {
$pos[$y][$x]{char} =
$secret ? $sdoorchar : $doorchar;
$pos[$y][$x]{colr} =
$secret ? $sdoorcolor : $doorcolor;
}
my $toroom = $pos[$y][$x]{room};
# We've connected to a new room.
$conn{$$room{room}}{$toroom}++;
$conn{$toroom}{$$room{room}}++;
push @conn, $toroom;
$connected = 1;
jot("*") if $debug > 6;
$connected = 1;
} else {
# We've connected to an already-connected room.
$connected = 1;
push @conn, 'dupe'
if not ++$attempt % $connectretry;
$connected = 1;
push @conn, 'dupe'
if not ++$attempt % $connectretry;
jot("d") if $debug > 7;
}
}
} elsif ($pos[$y][$x]{terr} eq 'hall') {
$connected = 1;
$connected = 1;
jot("f") if $debug > 6;
push @conn, 'fail'
if not ++$attempt % $connectretry;
if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} eq 'floor') {
$connected = 1;
jot("?") if $debug > 6;
push @conn, '????'
$connected = 1;
jot("?") if $debug > 6;
push @conn, '????'
if not ++$attempt % $connectretry;
} elsif ($pos[$y][$x]{terr} =~ /rock|default/) {
jot("#") if $debug > 8;
jot("#") if $debug > 8;
$pos[$y][$x]{terr} = 'hall';
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
}}
sub layout_non_rectangular_rooms {
$pos[$y][$x]{char} = $corridorchar;
$pos[$y][$x]{colr} = $corridorcolor;
} else {
warn "Unhandled terrain type: '$pos[$y][$x]{terr}'";
$connected = 1; push @conn, 'Error';
}
}}
}}
}}
$maxroomwidth += irr(($maxcols - $maxroomwidth) * 2/3);
$maxroomheight += irr(($maxrows - $maxroomheight) * 2/3);
my $avgwidth = ($minroomwidth + $maxroomwidth) / 2;
my $avgheight = ($minroomheight + $maxroomheight) / 2;
my $numofrooms = ($maxcols / $avgwidth)
* ($maxrows / $avgheight);
$numofrooms = int(
($numofrooms / 3)
+ rand($numofrooms / 3)
);
my $tries = 0;
while (($numofrooms > scalar @room) and ($tries++ < 50)) {
my $targetwidth = $maxroomwidth
- int rand($maxroomwidth - $minroomwidth);
my $targetheight = $maxroomheight
- int rand($maxroomheight - $minroomheight);
my $avgheight = ($minroomheight + $maxroomheight) / 2;
my $numofrooms = ($maxcols / $avgwidth)
* ($maxrows / $avgheight);
$numofrooms = int(
($numofrooms / 3)
+ rand($numofrooms / 3)
);
my $tries = 0;
while (($numofrooms > scalar @room) and ($tries++ < 50)) {
my $targetwidth = $maxroomwidth
- int rand($maxroomwidth - $minroomwidth);
my $targetheight = $maxroomheight
- int rand($maxroomheight - $minroomheight);
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
}}}
# Restore Horizontal Boundaries:
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
}}}
# Restore Horizontal Boundaries:
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $roomnum;
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
}}}
# Where there are more than two parallel walls, we
# want to put floor in the middle...
for my $y (1 .. ($maxrows - 2)) {
for my $x (1 .. ($maxcols - 2)) {
# Horizontal parallel walls (more likely):
if (($pos[$y - 1][$x]{terr} eq 'wall') and
($pos[$y][$x]{terr} eq 'wall') and
($pos[$y + 1][$x]{terr} eq 'wall') and
($pos[$y - 1][$x]{char} eq $horizwallchar) and
($pos[$y][$x]{char} eq $horizwallchar)) {
# Where there are more than two parallel walls, we
# want to put floor in the middle...
for my $y (1 .. ($maxrows - 2)) {
for my $x (1 .. ($maxcols - 2)) {
# Horizontal parallel walls (more likely):
if (($pos[$y - 1][$x]{terr} eq 'wall') and
($pos[$y][$x]{terr} eq 'wall') and
($pos[$y + 1][$x]{terr} eq 'wall') and
($pos[$y - 1][$x]{char} eq $horizwallchar) and
($pos[$y][$x]{char} eq $horizwallchar)) {
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}
# Vertical parallel walls (also possible):
if (($pos[$y][$x - 1]{terr} eq 'wall') and
($pos[$y][$x]{terr} eq 'wall') and
($pos[$y][$x + 1]{terr} eq 'wall') and
($pos[$y][$x - 1]{char} eq $vertwallchar) and
($pos[$y][$x]{char} eq $vertwallchar)) {
}
# Vertical parallel walls (also possible):
if (($pos[$y][$x - 1]{terr} eq 'wall') and
($pos[$y][$x]{terr} eq 'wall') and
($pos[$y][$x + 1]{terr} eq 'wall') and
($pos[$y][$x - 1]{char} eq $vertwallchar) and
($pos[$y][$x]{char} eq $vertwallchar)) {
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}
}}
# Other fixup would go here, if needed, but I think that
# might just about cover it.
}
}
sub layout_dense_rooms {
my $targetwidth = $maxroomwidth;
my $targetheight = $maxroomheight;
my $availtiles = $maxrows * $maxcols;
my ($iteration, $totaliteration);
while (($targetwidth >= $minroomwidth) and
($targetheight >= $minroomheight) and
($availtiles >= ($minroomwidth *
$minroomheight * 10))) {
my $height = ($targetheight > 3)
? $targetheight - irr($targetheight) : $targetheight;
my $width = ($targetwidth > 5)
? $targetwidth - irr($targetwidth) : $targetwidth;
my $rect = randomrect($height, $width);
if (rectavailable($rect)) {
jot("+", 0);
push @room, makeroom($rect);
#use Data::Dumper; print Dumper(+{ room => \@room });
printlevel() if $debug > 4;
}
}}
# Other fixup would go here, if needed, but I think that
# might just about cover it.
}
}
sub layout_dense_rooms {
my $targetwidth = $maxroomwidth;
my $targetheight = $maxroomheight;
my $availtiles = $maxrows * $maxcols;
my ($iteration, $totaliteration);
while (($targetwidth >= $minroomwidth) and
($targetheight >= $minroomheight) and
($availtiles >= ($minroomwidth *
$minroomheight * 10))) {
my $height = ($targetheight > 3)
? $targetheight - irr($targetheight) : $targetheight;
my $width = ($targetwidth > 5)
? $targetwidth - irr($targetwidth) : $targetwidth;
my $rect = randomrect($height, $width);
if (rectavailable($rect)) {
jot("+", 0);
push @room, makeroom($rect);
#use Data::Dumper; print Dumper(+{ room => \@room });
}
my $fitratio = int($availtiles * 5
/ ($targetwidth * $targetheight));
if ($iteration++ > $fitratio) {
# We've tried enough times at this size. Decrease size.
my $aspectratio = $targetwidth / $targetheight;
if (rand(100) <= (20 * $aspectratio)) {
$targetwidth -= (1 + int rand ($targetwidth /
$widthdivisor));
jot($_, 2) for split //, "W$targetwidth";
} else {
$targetheight -= (1 + int rand ($targetheight /
$heightdivisor));
jot($_, 2) for split //, "H$targetheight";
}
jot(" ");
$totaliteration += $iteration;
$iteration = 0;
} else {
jot();
}
}
}
sub printlevel {
my $fitratio = int($availtiles * 5
/ ($targetwidth * $targetheight));
if ($iteration++ > $fitratio) {
# We've tried enough times at this size. Decrease size.
my $aspectratio = $targetwidth / $targetheight;
if (rand(100) <= (20 * $aspectratio)) {
$targetwidth -= (1 + int rand ($targetwidth /
$widthdivisor));
jot($_, 2) for split //, "W$targetwidth";
} else {
$targetheight -= (1 + int rand ($targetheight /
$heightdivisor));
jot($_, 2) for split //, "H$targetheight";
}
jot(" ");
$totaliteration += $iteration;
$iteration = 0;
} else {
jot();
}
}
}
sub printlevel {
print color 'reset';
print "\n
print "\n
Layout Style: $layoutstyle ($layoutname{$layoutstyle})
Corridor Style: $corridorstyle ($corrname{$corridorstyle})\n\n";
for my $row (@pos) {
for my $cell (@$row) {
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
#} elsif ($$cell{objs}) { # TODO
if (ref $$cell{mons}) {
print color $$cell{mons}{colr} if $$cell{mons}{colr};
print $$cell{mons}{char};
} else {
print color $$cell{colr} if $$cell{colr};
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
if ($$cell{char}) {
print $$cell{char};
} elsif ($$cell{room}) {
my $digit = $$cell{room} % 10;
print $digit;
} else {
print $errorchar;
}
}
print color 'reset';
}
print color 'reset';
print "\n";
}
}
sub jot {
my ($char, $mindebuglevel) = @_;
$char ||= '.';
$mindebuglevel ||= 1;
if ($mindebuglevel + 3 <= $debug) {
print $char;
if (not ($jotcount++ % 60)) {
print "\n";
}
}
}
sub randomrect {
my ($theight, $twidth) = @_;
my $maxy = $maxrows - $theight - 1;
my $maxx = $maxcols - $twidth - 1;
my $starty = 1 + int rand $maxy;
my $startx = 1 + int rand $maxx;
return +{
starty => $starty,
startx => $startx,
stopy => $starty + $theight - 1,
stopx => $startx + $twidth - 1,
};
}
sub rectavailable {
my ($rect) = @_;
my ($char, $mindebuglevel) = @_;
$char ||= '.';
$mindebuglevel ||= 1;
if ($mindebuglevel + 3 <= $debug) {
print $char;
if (not ($jotcount++ % 60)) {
print "\n";
}
}
}
sub randomrect {
my ($theight, $twidth) = @_;
my $maxy = $maxrows - $theight - 1;
my $maxx = $maxcols - $twidth - 1;
my $starty = 1 + int rand $maxy;
my $startx = 1 + int rand $maxx;
return +{
starty => $starty,
startx => $startx,
stopy => $starty + $theight - 1,
stopx => $startx + $twidth - 1,
};
}
sub rectavailable {
my ($rect) = @_;
for my $y ($$rect{starty} .. $$rect{stopy}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
for my $x ($$rect{startx} .. $$rect{stopx}) {
if (defined $pos[$y][$x]{room}) {
return;
} elsif (not ($pos[$y][$x]{terr} =~ /default/)) {
return;
}
}
}
return $rect;
}
sub makeroom {
my ($room, %arg) = @_;
$$room{room} = ++$roomnum;
makefloor($room);
leaveroomforcorridors($room);
makewalls($room);
return $room;
}
sub makefloor {
my ($room) = @_;
for my $y ($$room{starty} .. $$room{stopy}) {
return;
} elsif (not ($pos[$y][$x]{terr} =~ /default/)) {
return;
}
}
}
return $rect;
}
sub makeroom {
my ($room, %arg) = @_;
$$room{room} = ++$roomnum;
makefloor($room);
leaveroomforcorridors($room);
makewalls($room);
return $room;
}
sub makefloor {
my ($room) = @_;
for my $x ($$room{startx} .. $$room{stopx}) {
$pos[$y][$x]{room} = $roomnum;
$pos[$y][$x]{terr} = 'floor';
$pos[$y][$x]{colr} = $floorcolor;
$pos[$y][$x]{char} = $floorchar;
}}
return $room;
}
sub makewalls {
my ($room) = @_;
# Horizontal Boundaries:
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
}}
return $room;
}
sub makewalls {
my ($room) = @_;
# Horizontal Boundaries:
for my $y (($$room{starty} - 1), ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1) .. ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{char} = $horizwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{room} ||= $$room{room};
}}}
# Vertical Boundaries:
for my $y (($$room{starty} - 1) .. ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
}}}
# Vertical Boundaries:
for my $y (($$room{starty} - 1) .. ($$room{stopy} + 1)) {
for my $x (($$room{startx} - 1), ($$room{stopx} + 1)) {
if (($x >= 0) and ($y >= 0) and
($x < $maxcols) and ($y < $maxrows)) {
$pos[$y][$x]{terr} = 'wall';
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
$pos[$y][$x]{char} = $vertwallchar;
$pos[$y][$x]{colr} = $wallcolor;
y => $y,
x => $x,
type => $terrain,
};
x => $x,
type => $terrain,
};
return [$y, $x];
}
}
sub placemonster {
my ($room, $type, $char, $colr) = @_;
}
}
sub placemonster {
my $tried = 0;
while ($tried++ < 15) {
# Only place one monster per tile:
while ($tried++ < 15) {
# Only place one monster per tile:
my ($y, $x) = placeonfloor($room);
if (($pos[$y][$x]{terr} eq 'floor') and
(not ref $pos[$y][$x]{mons})){
$pos[$y][$x]{mons} = +{
if (($pos[$y][$x]{terr} eq 'floor') and
(not ref $pos[$y][$x]{mons})){
char => $char || $errorchar,
type => $type || 'MONSTER',
colr => $colr || 'reset',
};
type => $type || 'MONSTER',
colr => $colr || 'reset',
};
return [$y, $x];
}}
}
sub placeonfloor {
my ($room) = @_;
my $miny = $$room{starty};
my $minx = $$room{startx};
my $maxy = $$room{stopy};
my $maxx = $$room{stopx};
}}
}
sub placeonfloor {
my ($room) = @_;
my $miny = $$room{starty};
my $minx = $$room{startx};
my $maxy = $$room{stopy};
my $maxx = $$room{stopx};
my $tried = 0;
while ($tried++ < 25) {
my $y = $miny + (int rand($maxy + 1 - $miny));
my $x = $minx + (int rand($maxx + 1 - $minx));
print "[$y,$x]" if $debug > 30;
if ($pos[$y][$x]{terr} eq 'floor') {
while ($tried++ < 25) {
my $y = $miny + (int rand($maxy + 1 - $miny));
my $x = $minx + (int rand($maxx + 1 - $minx));
print "[$y,$x]" if $debug > 30;
return ($y, $x);
}}
return ($miny, $minx);
}
}}
return ($miny, $minx);
}
Jonadab the Unsightly One
Dec 15, 2012, 5:31:15 PM12/15/12
to
Here's some sample output. (Actual output is in color,
assuming your terminal supports that. But I don't know
how to post colored text to usenet ;-)
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 2 (Systematic)
# #
## ##
######################## /------\ ###
# #/-+------------\ # /--|......| # ########
/+--#|..............+#####+.........| /---+----\ ###
|...#|..............| +.......<.| |'.......++###
|...#|..............| +--\---+--+#+.....o...+
/----\ |...#|..............| # # ##|.........|#
|}..}| |...#\------+-------/ # #####++........+###
|}#..| \---# # /--+------\ #++++-+---/ ##
|..}.| # # |.........|\ ## /##########
\-+--/ # # /---\ |..........| ++-|&&q|--\
# # # |_..| |..........| +...E&....|
# /----/+------+####+...+##+..........| |....&h...|
# |...........&|# |...| \---------// \--|>O&|--/
# |............|### \-+-/ \---/
# \----|.......| ### #
# \+----#-/ ## #
/---+\------\ # /+---\ ####
|...........| # #+#...| ###/--\
|...........+########|....+##++++..|--\
|....|------/ ####|....| |........|
\----/ ## #+----/ \--|..|--/
# # \--/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 1
Using layout style 1.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 1 (Dense Room Packing)
Corridor Style: 1 (Haphazard)
/---------------\ #
|E...E...H....d.| /---\ # /----\
|.........E..E..|##/------------------------\ |...| /+--\+.&..|
|......E..T....E+##+.......................}|#|...+###+...|+qfEd|
\----+----------/##+..........}.............+#+...| |...++.&..|
# |....}...............q...|#|...+###+.E.|\+---/
##### |.....}..............}...| \+-+/ |...| ##
# # /------\ \------+-+--------+------/ # # \#+-//+---\
/-+---+\ |`.`.`.| ##### ### /-#---------+-+--\ /-+\ |}.|.|
|}}..}.+#+.....`|/-+--\## ### |................| |&E+#+....|
\--+-+-/ |`.....||....|/+--+-+\ |................+#+..| |}.}.|
#########+.`.`.`||....+#......|/--\ |...........{....| \-+/ \+--+/
## ####\------/\---+/|x.....||q.+#+............o...| /-#---+--\##
/+--+-\############## |......||h.| \--+#----#-+-----/ |q.H.&q..| #
|.....| /------+---+\|}}....|\-+//---++----+-+---\ |.......'| #
|.....| |...........|\-+--+-/####+..........._...+## |qhFLq.qg+##
|...<.+##+...........| # # ### \-------+---+---/ ##+.....qq.| #
|...._| |...........|/-+--+--+-+-------\ # ########\------+#/ #
\-##+-/ |...........||.................+ # /-------#-----\/+\ #
/-++\ \---------#-/|.................# # |.............++}| #
|..}|/-----\ /---+\#+>................+/+-\ |.........T...++}+##
##+g..++.....+##+....+#|.................#+.{+#+....XJ...&..F++}|##
# |..&||.....| |.m.&|#\-----------------#|..| \-------------/\-/ #
# \---/\-----/ \----/####################\--/#####################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 2
Using layout style 1.
Placing corridors (style 2)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 2 (Systematic)
# ## # # /-------\ /----------------\ #/--\
# /---+---\ |.......| |................+##+.E+#
#/++---\ |.......+#############+.......| |................| |..|
|.B...+###+.......| # /---\ +--+----/ |................+##+++/
|.E...| \+--+---/ ####|...| ##########+................| ##
#+.....| /#--#----\ # ##|...+########## \-------+--------/ ###
|.....| # |..E.....|/+--+|...| ## /+---++---\ # /----++++E
\-++--+###+........#+o.&+#...| ## |.........| # ####+.......|
# ## ##|........#|&f.|\#--/ ## |.........|/----+---+--\|.......|
/+++---\#|....&...#\---//-+---++\|{........||...}.......||.......|
##+######+#+-+------# # |..&...J+\---------/|}..........||.......|
# \------/####--\ ######+...{&..|#/------\ |...........|\---+---/
# +..t.| ### \-------+#+......| |.........}.| /--#---\
#/----\ +{#B.| #/+\ /----------# |......| \-----------/ |g.....|
#|....+####|...Y| #|#| |.......j..+ \----+-/ # # +.&....|
#|....| #|oL..| +.| |...&......|# /---#-----------\ ###+......|
#\----/ #\----/ +.+#+.........g+##+......#........+######+...o..|
## # # +.| |..........| +...............| # \--#---/
#/--------+-----\ \+/ \----+----+/ \#--------------/ /-------+\ #
#|..|...........| # # ### /-+-\ /--------\ |......B.|
#|..............|/--+#++----+----+-+ |...+#+........|# |.......>|
#|..............||DD+#D..D...DD....+#+...| |.....ET.| |...H....|
#+..............||DD||..D.DDD......|#++--/ \--------/ |........|
#\--------------/\--/\-------------/ ## \--------/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 3
Using layout style 3.
Placing corridors (style 3)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 3 (Directed)
/++--\ //------------------\
# #####+..E&| |.......{.H....z.N..|
#//------++++++### #+...N| ######+.....&.......{.T...|
|...<........+#######+....+#### |.B.............W..O|
#|.......n....| ## \\-+-/ \\-----+--------++--/
|............| ## # # ##
\\--------++++ ## # # ##
#### # # ##
###### #/-----------------+-\\ /++-----\
# ## #### #|.....}..............+#######++.......|
# ## ###+...........{........+#### |........|
## #+....................| |........|
## #\+++++++++--------+-// \\-------/
## ######### #### #
# /-------+-++++++## # ## #### #
# |..............| # ### ####+-/+-\
# |..............| # ## ###+....|
|..............+### /++++ #+..Hg|
# \--------------/ ##+++}..|-\ |....|
|..}.}..| \-+.o|
\-|>..|-/ |.R|
\---/ \--/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
# /---------------\
# /---+/----\----\ /----------|....F..........|
# |....+.........| |........................R.|
# |..............| |..........+.............g&|
# |..............| |..............J......f....|
# \---++....+----/ +----------|...........E...+##
## |....| ## \-----+---------/ #
## \+---/ # ## #
# # /------#------\ # # #
# ##|...X.&h......|## # #
# #|HE.O.......&.|# # #
# +...f&E.......+# # #
# |&..gE......x.| # #
####+..&..Hz......| /-----------+---------------+-\\
|...j.H.......| |.............................++
|...>.......&.| |.............<................|
\+------------/ |..............................|
# \------+------------------+-+-//
#
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 1
Using layout style 1.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 1 (Dense Room Packing)
Corridor Style: 1 (Haphazard)
/-------\/-------------------\ /-\ ###
|.....<.||...................| /---------\ |.| # #
|.......||...................| |.........+#+.| /-+-+--\
\---+-+-/|...................+#####+.......E.| \+/ /----\|......|
# # \-----####+-----+---/ \---------/ # |}...||......|
# # /-+-\ # /----+--\+}}..|\------/
/-+-+-----\|&}n|/----\/+--------------\##+.......|+....+#####
|...}.}...||n}&++...&||.....R.........|# |.......||}..}| #
|..}......|\-+-/|&.g.||...............|# |.......|\--#-/ #
\#-------+/ # \+---/|..........g....|# |.......|/--+-++-\ #
/-+----\ /#---+---####\|...............|# \-------/|...Tg._| #
|d.z.E{|#|............#\---------+-----/# ####+&W.&&..| #
|......+#+............#/------\/-+------+------+-\ \-------/ #
\------/ |............#|..P..|||.................|/----------+--\
|.......U....#+......||.................++.............|
\------------/\-+----/\-----------------/|.............|
/-----+---------\ /##---\ /----------------\|.............|
|......w........| |.....| |................|\-------------/
/-\ |..............&+####|.....| |................|
|w+#+...............| #+.....| |................| /----------\
|n| |...............| \-+--+/#+................+#|.........f|
\-/ \---------------/ ## # \+---------------/#+....>.....|
## # # #\----------/
#######################################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 2
Using layout style 2.
Placing corridors (style 1)...
Unhandled terrain type: 'pool' at /b4/perl/nethack-dense-room-
packer.pl line 1373.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 1 (Haphazard)
### # # ###### # # # #
# #################+.XqX| ## #### # #
# ## |.q.g|---+---+-+- -------+------+--
# # |....|..-------+++|------.....g...+#
# # # -----+----+|........+#+......|....&..h|###
# # |........|-++--------.|....d<|.....H..| #
## -+----------|------..|#------....+--------+------+- ##
# |...n##.....|#&&&.|..|## ----+--------+. # # ##
# |...........|}.nnn|..|#######+....&........+###### ###
--+------.........--+-----+-# ####|-------------|-- # # #
|.....|.+#&.........#...| # # #####+-----+...+...-.+############
|.....--|----+------+-----+-+--### |.....+---+-----|---- #
|.......|##### # ####+}.o..+### |....|..........|...| ## #
|.......+#---+-# ## |}.}..|### |....|.}....>...+#}}| # #
--+--+---#+DDD+#########+.&.}}| ##-----------------..}+########
# # |.DD| -+--+-+------+-----+------.------- #
# # #+DD.+#######+####+#+#.--`.`.`..#......+## #
# # #+D.D|#######|...#|#|#+..+#######.....`|###############
# # --+-- |....-+-++--++-----+---...| #
# # ###########+...#+.|.-++-`.`.`.`.`+#.`| # #
## # ## # -----+---.++.---------|---- #
#########################------------------ # #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 3
Using layout style 3.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 1 (Haphazard)
# ################################ # # # ###
# # ## # ## # # ### ### # # # ## #
## # # # #|....| # # # # #
# # |....| /-------+-\# # #
## # # # # # # |....| # |.......O.|# # #
# # ## # |....|# #|...#.....|# # #
# # # # |....+########+.{.......|## /+-+
# # ### # ## |....| ## |.........|#/-|g<|
# # ## # |..>.+########+..dW.....|#|.+dL|
# # # # # # ## |....| # #|..E.g....+#|..&&|
# # # |....| \---------/#|..Ht|
# # # ## |....| # ##|..Jz|
# # # # # |....|# # #|..Wg|
### # # # # # # |....|# # #|..YR|
#/-+\# # # |....| # #|...E|
####|'H|------------------------\ \----/ # # # #|...o|
####+._.........................|## # # #|..H.|
## |...........................|## # #|..--/
####+..|------------------------/ # # # #\-+/
# \+-/ # # # # # ## ##
## ### # # # # # # ##
##################################################################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 1)...
Unhandled terrain type: 'tree' at /b4/perl/nethack-dense-room-
packer.pl line 1373.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 1 (Haphazard)
-------+-++---- ----
###########+.n&.&-+-++...| ----++--|----
######### |&n&.|}.L----++----------- |....|##|...|
# |.&{&+}..+{n}||..n...n..n+###########+..-++-+--..|
# -------------+-..n..#n...| |.#+.+.x||#.|
# ....+----###.{...nn.| ----+|---+-++--
# -------+.....----------|--------#+.|.|--.-+--
######+&<&.&.------+--------------...+#+#+.|..|
## # |--+-|+..{...+.........{....|..| --|--.}|
## ###+X&&+&|......--+-------+----|--- |.}.}|
--+-+------++--+-.....+............| ####------
|......|...|----.------------+++-+----+--# ###
|......+{qF++...|....|...|.|.|.###....}.|# # #
|......--+--|...+#...|..-++++|-+-+--.}}.|###### ---+-#
######+...........|...|....--++++}.-..#.}|.}..+#########+...|#
# ---+--------++---.......|-.++-+----|----+----+----|---|+--
# .-+----------+--+---+--|+--.......| |...........|@_.|..|
# ###+R..............+|--+-+++..-......+##+...........|...|..|
# ###|.....{........|.|.>...--+-+-+-----##|...........-----..|
# #|.-------------+.|.......#.+#########+..................|
#######+.+dqq&&&E&EEE+-+|-------+-- -----+----+--+------
# ---------------++- # # ##
#########+------------ ################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 1.
Placing corridors (style 3)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 3 (Directed)
/---------++---------\ /----\
/--------------------\ |....................######..o.|
#|....................|/--\/-+++++#..L.................|/--\|Ozw.|
#|.g..................|+..+#}}.}}||....................#+..|\-#--/
#|....................#+..+#}}}.}+#....................||..|/-+---\
#\--------#############++++\+--+++#++++++++++++++++++++#++++#.....|
+--+++++++++++\/-++#/-####################-#############--# |}.&.>|
+..<..........||{g.#|LELL+#`.`.`.`.`||....................+#\-#---/
|.............|+ggg#+LLLL||.........||....................+##+++--\
\------+++++++#+---/\++++/|`.`.`.`.`||....................+##+....|
+--+++### ###-#-------/|....................+ #+....|
|....+#/------------------++++-\ \----------######--#-/ ++---/
+....+#+.......................+###+++++++++##++++++++++++-\/##
+---++ |.......................+###+DDDD.DD+# |............#+{#+--\
/-###\ |.......................+###+D.DD.D.| |............||}|+X.|
|....+#+.......................####+++++---/ \-+++++----++/\-/|.P|
|....| |.......................#++############### # \--/
+----/ \-----------+++++++-+-++#|...............+#++++++++++++#--\
#--------------######\ ### |.............#.||........X......|
+.....&..............| /--++---\|.......{.......||...............|
|....................| |.......||...............||...............|
|....................| |.......||...............||...............|
|....................| \-------/\---------------/|...............|
\--------------------/ \---------------/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 3)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 3 (Directed)
# ## #### ## #### ###### # ## # ## # ## ## ##
## ## ## # # # ## ## # # # # # # ## ## # ###
####### #### # # # ## # ##### # # # # ### ### # ##
## # # # #---------------### # ## #### # ### # ## #
## # ## # # |J...####..##.|######### # ## # ## # ### ###
## # ### |H.+++------+++--# # ## # # # ### # # ## # # ##
# ## ## ##### |##+......##Yo+o+##--------------------- # ### # #
+----++-------++++------++++----|+++....E..............| ##### ##
+.&.....#|..#+......---+D-|++++.+++++++#...............| # #
+.......#+###|..D.D|D.DD|<|#.##+..{|_.+................|# ## ####
+-------++++++----++++-----+---|---|..|................|# ### # #
# .--|+++.++++.+++++++++++.+++E+.E@+--|----------------- ## # #
# |..+...+....++##+n&|.E&E|EE.||.E.|>.| ## # ### # ## # # ## #####
# |..|...-----|.+-|--|-----+--|-+------## ### # ### # # #
##|..|.....|..||..|#&|....|}PE|#+ # ## # #### ### ## ### # #
#|..|...}....||..|n{|....|Hqt|#|## ## ## # # ## # # # ##
# -------------------------++-+#| # # # ### # #### ## #
####### # # # # |...#.| # # ## # ## ## # #####
# ## ## ## ## # ## |RU}}}|## # #### # # ## ### # # #
### # # #### # # ------- ### # # ### ### ### # ## ##
## ## ### # ## ### # # # # # ### # # ### # ## ### ###
#### # ### ## # ### # ## # #### ## ### # # ### # # # ##
# ### ## # # ## ####### #### # # # # ## # ### ## #
# ### ## ## ## ### # # ## ### #### # ## #### ## ##
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 1.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 1 (Dense Room Packing)
Corridor Style: 1 (Haphazard)
/---\ /----------------------\ /------------\
|...|/-\ |......................| |............|
\+--/|R|/-----------\#+......................|#|............+#####
## |H+#...........| |......................+#+.....>......| #
#####+P|#...........| |......................| |............+#####
/+\ \-/|......g....| \----+-----------------/ \-----+------/ #
|.| |...........| # /-------------##\ #####
|.| \---+-------/ /--+--------\ |.}.............| /---+---\
|.| # |...........|#|...............| |.EwqE..|
\+/ /--------+----\ |...........+#+...............+##+....q..|
# |......O......| |...........| |..}............|##|.....z.|
# |.........U...| \#--#-#-----/ \---------------/ \-------/
# |.............| /-+--+-+-\ /-------------------\
# |.............| |......<.+###+............&.g...q|
# \-----+-------/ \--#-----/ \-------------------//-------\
# # /---+\/------------------------\ |.......|
# # ##########+}}}}||...........N............| |.......|
# # # |}O}a||............&...........+###+.......|
# /------+--+------\##+}}}P+#...........&...........q| |.......|
##+................| \----/|........................+###\--+----/
##|................|/--\ \--#----#----#---#--+#+-+/ # #
##|................||..+####/--+----++---+---+--\ # #####
##|................||..| #+..E................| # #
##\----------------/\--/ #\-------------------/ ##############
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 2)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 2 (Systematic)
-----------------
.++--.......----|--
|....|.....|....|.|
|....+#....|...#+#| ------------------------
------+-----------+------ -.------------+-H..NdNY.|
# |..-------+.....| ||F.....mL..LLN&|.....##+#######
# |............o..| ||N...-------+-++---------+#####
##----------+------ ------N----.-+--+....&>.|.|#
## # -....|....-....+--------.|##
---+---------# ---------.----.-.---+---- ###
##+O#++++++++-.+------------ |.|..---|------.| ## #
+.+N...&.&Et|.{....{..|..| |.|.|..}|.E.&}.|| ### ##
-+.----------.........|..| |.|.|..}+.}R}&.||# ##### ##
++&..q......---------|--- |.|.|.}}|.}....||## ##### #
-.-------------------- ++++-+-----+-----+-+++++++-+-
---+++.# #######################+..............+
###+.....|# # ------++-+-+-----+-+..............+#
# |...w.+################+#+o...ooo|#.......+..............+#
# |.....+############ |.|oo..ooo|#.gm....-++-++-+++++-+-+#
# +.....| # # # -------+-+++++------################
###------- ## # # #################################
## ## # ######### # ##### ##### ##########
Using layout style 1.
Placing corridors (style 2)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 2 (Systematic)
# /---------\ /---------------\
/---+----\ |.........| +.......##......|
|........|/-\ #+.........+#+}..........W&..|
|........||#+#+++----------------\ #\---------/ \------+--------/
\---+-+++#|E||...................| # /-------------#-------\
# # +++|..................E| # |.....................|
/---+-+----#\#....&..............|/+----\|.....................|
##+...........+#...................||&n&}#||.....................|
|...........||...................||nnnn}||.....................|
|...........|\-+++---------+-----/\--+--/\------------###---+--/
|...........+## # /---#-----------------\ ####
+...........| /+--\ |.....................| ++--\
#-----+-+---/ |...|##+.................#...+####+#}}|
/+\ /--#-#---------------\ |...|# |.....................| +#}}|
|.| |....................| \---/# |..................g..| \+--/
|.| |....................| /--\# \+------++------------/ #
\-/ |...........F........+##+..|# # ## /-------------+\
|.................T..| |.>|################+........n.....|
\------+-------------/ \+-/# # ###########+..}n.&...#n.#.+##
# /-----------#--#--+-\+---++-\ |.&..n.........|
/---------+---\ |...................#+...t..+##+.n{........n..|
|.............+#+...................||......| \--------------/
|...L.{.......| \-------------------/\----+-/
\-------------/ #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 3.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 1 (Haphazard)
# # # # ###############
# //-----------\ ## # #
# |............| # # ### /+---\ ## #
|............| # # # ## ##+....| # # #
++...........| # ## # # |<...| # ##
# # \\-+---------/ # /--+---\# # |....+##########
# # # # #############+.Y'.&.+\# # |....| # #
/-------+-\ # # |..o....|## ## \-+--/ #
|F._T...Uq|# # # # |E.X..B.| ### # # ###########
|Ez.F.LoEU| ### \----+-// # # # # #
|.Uq..>...| # # # ## # # ## # #
\---------/ # # ### # ##/+-\ # #
# ## # # # # ### /+|.g|-\ #
# /-+---------\ /+---\# # ## |..E...| # #
# /----------|...........| # |q..#|\ ## |...f..| # #
# # |..........+...........| |.H...| # |...F+.| #
|......................| |P&.&.| # \-\+-/-/ #
\----------\-----------/ # \-.+..| # # # #
# /----\# /---\\ #\-+--/ # # #
# /|....+##########+`.`.| # ## # # /--+-----\\ #
# ++o..m| |...++ ## |........++ #
# |.H&.&| |`.`|/###################+.........| #
|....-/ \---/ # # #|J.E......| #
# \----/ ###################\--------// #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 2)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 2 (Systematic)
# ---------------- # -------------
-------------------- # ## ---+.+++++++++++++.| # |...........|
|E......++++++++++++- ## |...| ...E...E....|+####+...........|
|......|@...._...<.+| ### |...|g........&...|+####+##.....z...|
#+.&....+....#######++###### |...|.+-----+-----|---+--------++++++E
|......--------+-+-++#######+###+#+###.....'PE+&+E++-.+--.-+-. ##
|...........#+#####+---++++----+--+-+-|------+||'|'.m|...+#..+###
-------------|---+-+#.|.q+..+++.++...+|.......+--|+--+...|...|###
-....#+##+.#+.....+..++-+.++++++-+-++.......+...+ #
----+-++++---...}-|--#}}||.........|-+++-+--+-+++ #
# # # -...++++.---+-+++++++++++++.+--+++--#### #
# +-----+--.|...#...####...#.#.|# # ###### #
# |.&......||..................|# # ######
# #########+........+++++++-----+-----++-# # -++++##
# ## ###+........+ ###### |#..###+##########+g..+##
## # |........| # ###|#.....| ## # |#a.+##
# # # ---------- ## -+-+--------++--+----#..|#
# ## ### ##########+...................+#.>|#
## # #--+---+++--.................+#t.|#
###### ##+.#...#.|.|.................|+++-#
# # ## ## |.#---+------------+---------######
########################+.#+.E.###+#########+########### #
# ###########+..|.E....|.........| ## ## ##
# ### --------------------- ## ###
nathan@warthog:~$
assuming your terminal supports that. But I don't know
how to post colored text to usenet ;-)
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 2 (Systematic)
# #
## ##
######################## /------\ ###
# #/-+------------\ # /--|......| # ########
/+--#|..............+#####+.........| /---+----\ ###
|...#|..............| +.......<.| |'.......++###
|...#|..............| +--\---+--+#+.....o...+
/----\ |...#|..............| # # ##|.........|#
|}..}| |...#\------+-------/ # #####++........+###
|}#..| \---# # /--+------\ #++++-+---/ ##
|..}.| # # |.........|\ ## /##########
\-+--/ # # /---\ |..........| ++-|&&q|--\
# # # |_..| |..........| +...E&....|
# /----/+------+####+...+##+..........| |....&h...|
# |...........&|# |...| \---------// \--|>O&|--/
# |............|### \-+-/ \---/
# \----|.......| ### #
# \+----#-/ ## #
/---+\------\ # /+---\ ####
|...........| # #+#...| ###/--\
|...........+########|....+##++++..|--\
|....|------/ ####|....| |........|
\----/ ## #+----/ \--|..|--/
# # \--/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 1
Using layout style 1.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 1 (Dense Room Packing)
Corridor Style: 1 (Haphazard)
/---------------\ #
|E...E...H....d.| /---\ # /----\
|.........E..E..|##/------------------------\ |...| /+--\+.&..|
|......E..T....E+##+.......................}|#|...+###+...|+qfEd|
\----+----------/##+..........}.............+#+...| |...++.&..|
# |....}...............q...|#|...+###+.E.|\+---/
##### |.....}..............}...| \+-+/ |...| ##
# # /------\ \------+-+--------+------/ # # \#+-//+---\
/-+---+\ |`.`.`.| ##### ### /-#---------+-+--\ /-+\ |}.|.|
|}}..}.+#+.....`|/-+--\## ### |................| |&E+#+....|
\--+-+-/ |`.....||....|/+--+-+\ |................+#+..| |}.}.|
#########+.`.`.`||....+#......|/--\ |...........{....| \-+/ \+--+/
## ####\------/\---+/|x.....||q.+#+............o...| /-#---+--\##
/+--+-\############## |......||h.| \--+#----#-+-----/ |q.H.&q..| #
|.....| /------+---+\|}}....|\-+//---++----+-+---\ |.......'| #
|.....| |...........|\-+--+-/####+..........._...+## |qhFLq.qg+##
|...<.+##+...........| # # ### \-------+---+---/ ##+.....qq.| #
|...._| |...........|/-+--+--+-+-------\ # ########\------+#/ #
\-##+-/ |...........||.................+ # /-------#-----\/+\ #
/-++\ \---------#-/|.................# # |.............++}| #
|..}|/-----\ /---+\#+>................+/+-\ |.........T...++}+##
##+g..++.....+##+....+#|.................#+.{+#+....XJ...&..F++}|##
# |..&||.....| |.m.&|#\-----------------#|..| \-------------/\-/ #
# \---/\-----/ \----/####################\--/#####################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 2
Using layout style 1.
Placing corridors (style 2)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 2 (Systematic)
# ## # # /-------\ /----------------\ #/--\
# /---+---\ |.......| |................+##+.E+#
#/++---\ |.......+#############+.......| |................| |..|
|.B...+###+.......| # /---\ +--+----/ |................+##+++/
|.E...| \+--+---/ ####|...| ##########+................| ##
#+.....| /#--#----\ # ##|...+########## \-------+--------/ ###
|.....| # |..E.....|/+--+|...| ## /+---++---\ # /----++++E
\-++--+###+........#+o.&+#...| ## |.........| # ####+.......|
# ## ##|........#|&f.|\#--/ ## |.........|/----+---+--\|.......|
/+++---\#|....&...#\---//-+---++\|{........||...}.......||.......|
##+######+#+-+------# # |..&...J+\---------/|}..........||.......|
# \------/####--\ ######+...{&..|#/------\ |...........|\---+---/
# +..t.| ### \-------+#+......| |.........}.| /--#---\
#/----\ +{#B.| #/+\ /----------# |......| \-----------/ |g.....|
#|....+####|...Y| #|#| |.......j..+ \----+-/ # # +.&....|
#|....| #|oL..| +.| |...&......|# /---#-----------\ ###+......|
#\----/ #\----/ +.+#+.........g+##+......#........+######+...o..|
## # # +.| |..........| +...............| # \--#---/
#/--------+-----\ \+/ \----+----+/ \#--------------/ /-------+\ #
#|..|...........| # # ### /-+-\ /--------\ |......B.|
#|..............|/--+#++----+----+-+ |...+#+........|# |.......>|
#|..............||DD+#D..D...DD....+#+...| |.....ET.| |...H....|
#+..............||DD||..D.DDD......|#++--/ \--------/ |........|
#\--------------/\--/\-------------/ ## \--------/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 3
Using layout style 3.
Placing corridors (style 3)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 3 (Directed)
/++--\ //------------------\
# #####+..E&| |.......{.H....z.N..|
#//------++++++### #+...N| ######+.....&.......{.T...|
|...<........+#######+....+#### |.B.............W..O|
#|.......n....| ## \\-+-/ \\-----+--------++--/
|............| ## # # ##
\\--------++++ ## # # ##
#### # # ##
###### #/-----------------+-\\ /++-----\
# ## #### #|.....}..............+#######++.......|
# ## ###+...........{........+#### |........|
## #+....................| |........|
## #\+++++++++--------+-// \\-------/
## ######### #### #
# /-------+-++++++## # ## #### #
# |..............| # ### ####+-/+-\
# |..............| # ## ###+....|
|..............+### /++++ #+..Hg|
# \--------------/ ##+++}..|-\ |....|
|..}.}..| \-+.o|
\-|>..|-/ |.R|
\---/ \--/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
# /---------------\
# /---+/----\----\ /----------|....F..........|
# |....+.........| |........................R.|
# |..............| |..........+.............g&|
# |..............| |..............J......f....|
# \---++....+----/ +----------|...........E...+##
## |....| ## \-----+---------/ #
## \+---/ # ## #
# # /------#------\ # # #
# ##|...X.&h......|## # #
# #|HE.O.......&.|# # #
# +...f&E.......+# # #
# |&..gE......x.| # #
####+..&..Hz......| /-----------+---------------+-\\
|...j.H.......| |.............................++
|...>.......&.| |.............<................|
\+------------/ |..............................|
# \------+------------------+-+-//
# ## ## ##
# # ############
# ### ## ## #
# ## # #######
######################################################
# # ############
# ### ## ## #
# ## # #######
#
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 1
Using layout style 1.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 1 (Dense Room Packing)
Corridor Style: 1 (Haphazard)
/-------\/-------------------\ /-\ ###
|.....<.||...................| /---------\ |.| # #
|.......||...................| |.........+#+.| /-+-+--\
\---+-+-/|...................+#####+.......E.| \+/ /----\|......|
# # \-----####+-----+---/ \---------/ # |}...||......|
# # /-+-\ # /----+--\+}}..|\------/
/-+-+-----\|&}n|/----\/+--------------\##+.......|+....+#####
|...}.}...||n}&++...&||.....R.........|# |.......||}..}| #
|..}......|\-+-/|&.g.||...............|# |.......|\--#-/ #
\#-------+/ # \+---/|..........g....|# |.......|/--+-++-\ #
/-+----\ /#---+---####\|...............|# \-------/|...Tg._| #
|d.z.E{|#|............#\---------+-----/# ####+&W.&&..| #
|......+#+............#/------\/-+------+------+-\ \-------/ #
\------/ |............#|..P..|||.................|/----------+--\
|.......U....#+......||.................++.............|
\------------/\-+----/\-----------------/|.............|
/-----+---------\ /##---\ /----------------\|.............|
|......w........| |.....| |................|\-------------/
/-\ |..............&+####|.....| |................|
|w+#+...............| #+.....| |................| /----------\
|n| |...............| \-+--+/#+................+#|.........f|
\-/ \---------------/ ## # \+---------------/#+....>.....|
## # # #\----------/
#######################################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 2
Using layout style 2.
Placing corridors (style 1)...
Unhandled terrain type: 'pool' at /b4/perl/nethack-dense-room-
packer.pl line 1373.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 1 (Haphazard)
### # # ###### # # # #
# ## ## # # # #################
# # -+--+-## ############## # #
# #################+.XqX| ## #### # #
# ## |.q.g|---+---+-+- -------+------+--
# # |....|..-------+++|------.....g...+#
# # # -----+----+|........+#+......|....&..h|###
# # |........|-++--------.|....d<|.....H..| #
## -+----------|------..|#------....+--------+------+- ##
# |...n##.....|#&&&.|..|## ----+--------+. # # ##
# |...........|}.nnn|..|#######+....&........+###### ###
--+------.........--+-----+-# ####|-------------|-- # # #
|.....|.+#&.........#...| # # #####+-----+...+...-.+############
|.....--|----+------+-----+-+--### |.....+---+-----|---- #
|.......|##### # ####+}.o..+### |....|..........|...| ## #
|.......+#---+-# ## |}.}..|### |....|.}....>...+#}}| # #
--+--+---#+DDD+#########+.&.}}| ##-----------------..}+########
# # |.DD| -+--+-+------+-----+------.------- #
# # #+DD.+#######+####+#+#.--`.`.`..#......+## #
# # #+D.D|#######|...#|#|#+..+#######.....`|###############
# # --+-- |....-+-++--++-----+---...| #
# # ###########+...#+.|.-++-`.`.`.`.`+#.`| # #
## # ## # -----+---.++.---------|---- #
#########################------------------ # #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 3
Using layout style 3.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 1 (Haphazard)
# ################################ # # # ###
# # ## # ## # # ### ### # # # ## #
# # # # # # ###################### # #
### # /-+--\ # # # # ### ###
## # # # #|....| # # # # #
# # |....| /-------+-\# # #
## # # # # # # |....| # |.......O.|# # #
# # ## # |....|# #|...#.....|# # #
# # # # |....+########+.{.......|## /+-+
# # ### # ## |....| ## |.........|#/-|g<|
# # ## # |..>.+########+..dW.....|#|.+dL|
# # # # # # ## |....| # #|..E.g....+#|..&&|
# # # |....| \---------/#|..Ht|
# # # ## |....| # ##|..Jz|
# # # # # |....|# # #|..Wg|
### # # # # # # |....|# # #|..YR|
#/-+\# # # |....| # #|...E|
####|'H|------------------------\ \----/ # # # #|...o|
####+._.........................|## # # #|..H.|
## |...........................|## # #|..--/
####+..|------------------------/ # # # #\-+/
# \+-/ # # # # # ## ##
## ### # # # # # # ##
##################################################################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 1)...
Unhandled terrain type: 'tree' at /b4/perl/nethack-dense-room-
packer.pl line 1373.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 1 (Haphazard)
-------+-++---- ----
###########+.n&.&-+-++...| ----++--|----
######### |&n&.|}.L----++----------- |....|##|...|
# |.&{&+}..+{n}||..n...n..n+###########+..-++-+--..|
# -------------+-..n..#n...| |.#+.+.x||#.|
# ....+----###.{...nn.| ----+|---+-++--
# -------+.....----------|--------#+.|.|--.-+--
######+&<&.&.------+--------------...+#+#+.|..|
## # |--+-|+..{...+.........{....|..| --|--.}|
## ###+X&&+&|......--+-------+----|--- |.}.}|
--+-+------++--+-.....+............| ####------
|......|...|----.------------+++-+----+--# ###
|......+{qF++...|....|...|.|.|.###....}.|# # #
|......--+--|...+#...|..-++++|-+-+--.}}.|###### ---+-#
######+...........|...|....--++++}.-..#.}|.}..+#########+...|#
# ---+--------++---.......|-.++-+----|----+----+----|---|+--
# .-+----------+--+---+--|+--.......| |...........|@_.|..|
# ###+R..............+|--+-+++..-......+##+...........|...|..|
# ###|.....{........|.|.>...--+-+-+-----##|...........-----..|
# #|.-------------+.|.......#.+#########+..................|
#######+.+dqq&&&E&EEE+-+|-------+-- -----+----+--+------
# ---------------++- # # ##
#########+------------ ################
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 1.
Placing corridors (style 3)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 3 (Directed)
/---------++---------\ /----\
/--------------------\ |....................######..o.|
#|....................|/--\/-+++++#..L.................|/--\|Ozw.|
#|.g..................|+..+#}}.}}||....................#+..|\-#--/
#|....................#+..+#}}}.}+#....................||..|/-+---\
#\--------#############++++\+--+++#++++++++++++++++++++#++++#.....|
+--+++++++++++\/-++#/-####################-#############--# |}.&.>|
+..<..........||{g.#|LELL+#`.`.`.`.`||....................+#\-#---/
|.............|+ggg#+LLLL||.........||....................+##+++--\
\------+++++++#+---/\++++/|`.`.`.`.`||....................+##+....|
+--+++### ###-#-------/|....................+ #+....|
|....+#/------------------++++-\ \----------######--#-/ ++---/
+....+#+.......................+###+++++++++##++++++++++++-\/##
+---++ |.......................+###+DDDD.DD+# |............#+{#+--\
/-###\ |.......................+###+D.DD.D.| |............||}|+X.|
|....+#+.......................####+++++---/ \-+++++----++/\-/|.P|
|....| |.......................#++############### # \--/
+----/ \-----------+++++++-+-++#|...............+#++++++++++++#--\
#--------------######\ ### |.............#.||........X......|
+.....&..............| /--++---\|.......{.......||...............|
|....................| |.......||...............||...............|
|....................| |.......||...............||...............|
|....................| \-------/\---------------/|...............|
\--------------------/ \---------------/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 3)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 3 (Directed)
# ## #### ## #### ###### # ## # ## # ## ## ##
## ## ## # # # ## ## # # # # # # ## ## # ###
####### #### # # # ## # ##### # # # # ### ### # ##
## # # # #---------------### # ## #### # ### # ## #
## # ## # # |J...####..##.|######### # ## # ## # ### ###
## # ### |H.+++------+++--# # ## # # # ### # # ## # # ##
# ## ## ##### |##+......##Yo+o+##--------------------- # ### # #
+----++-------++++------++++----|+++....E..............| ##### ##
+.&.....#|..#+......---+D-|++++.+++++++#...............| # #
+.......#+###|..D.D|D.DD|<|#.##+..{|_.+................|# ## ####
+-------++++++----++++-----+---|---|..|................|# ### # #
# .--|+++.++++.+++++++++++.+++E+.E@+--|----------------- ## # #
# |..+...+....++##+n&|.E&E|EE.||.E.|>.| ## # ### # ## # # ## #####
# |..|...-----|.+-|--|-----+--|-+------## ### # ### # # #
##|..|.....|..||..|#&|....|}PE|#+ # ## # #### ### ## ### # #
#|..|...}....||..|n{|....|Hqt|#|## ## ## # # ## # # # ##
# -------------------------++-+#| # # # ### # #### ## #
####### # # # # |...#.| # # ## # ## ## # #####
# ## ## ## ## # ## |RU}}}|## # #### # # ## ### # # #
### # # #### # # ------- ### # # ### ### ### # ## ##
## ## ### # ## ### # # # # # ### # # ### # ## ### ###
#### # ### ## # ### # ## # #### ## ### # # ### # # # ##
# ### ## # # ## ####### #### # # # # ## # ### ## #
# ### ## ## ## ### # # ## ### #### # ## #### ## ##
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 1.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 1 (Dense Room Packing)
Corridor Style: 1 (Haphazard)
/---\ /----------------------\ /------------\
|...|/-\ |......................| |............|
\+--/|R|/-----------\#+......................|#|............+#####
## |H+#...........| |......................+#+.....>......| #
#####+P|#...........| |......................| |............+#####
/+\ \-/|......g....| \----+-----------------/ \-----+------/ #
|.| |...........| # /-------------##\ #####
|.| \---+-------/ /--+--------\ |.}.............| /---+---\
|.| # |...........|#|...............| |.EwqE..|
\+/ /--------+----\ |...........+#+...............+##+....q..|
# |......O......| |...........| |..}............|##|.....z.|
# |.........U...| \#--#-#-----/ \---------------/ \-------/
# |.............| /-+--+-+-\ /-------------------\
# |.............| |......<.+###+............&.g...q|
# \-----+-------/ \--#-----/ \-------------------//-------\
# # /---+\/------------------------\ |.......|
# # ##########+}}}}||...........N............| |.......|
# # # |}O}a||............&...........+###+.......|
# /------+--+------\##+}}}P+#...........&...........q| |.......|
##+................| \----/|........................+###\--+----/
##|................|/--\ \--#----#----#---#--+#+-+/ # #
##|................||..+####/--+----++---+---+--\ # #####
##|................||..| #+..E................| # #
##\----------------/\--/ #\-------------------/ ##############
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 2)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 2 (Systematic)
-----------------
.++--.......----|--
|....|.....|....|.|
|....+#....|...#+#| ------------------------
------+-----------+------ -.------------+-H..NdNY.|
# |..-------+.....| ||F.....mL..LLN&|.....##+#######
# |............o..| ||N...-------+-++---------+#####
##----------+------ ------N----.-+--+....&>.|.|#
## # -....|....-....+--------.|##
---+---------# ---------.----.-.---+---- ###
##+O#++++++++-.+------------ |.|..---|------.| ## #
+.+N...&.&Et|.{....{..|..| |.|.|..}|.E.&}.|| ### ##
-+.----------.........|..| |.|.|..}+.}R}&.||# ##### ##
++&..q......---------|--- |.|.|.}}|.}....||## ##### #
-.-------------------- ++++-+-----+-----+-+++++++-+-
---+++.# #######################+..............+
###+.....|# # ------++-+-+-----+-+..............+#
# |...w.+################+#+o...ooo|#.......+..............+#
# |.....+############ |.|oo..ooo|#.gm....-++-++-+++++-+-+#
# +.....| # # # -------+-+++++------################
###------- ## # # #################################
## ## # ######### # ##### ##### ##########
## ## # # # ### #### ###### ###
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 1.
Placing corridors (style 2)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 2 (Systematic)
# /---------\ /---------------\
/---+----\ |.........| +.......##......|
|........|/-\ #+.........+#+}..........W&..|
|........||#+#+++----------------\ #\---------/ \------+--------/
\---+-+++#|E||...................| # /-------------#-------\
# # +++|..................E| # |.....................|
/---+-+----#\#....&..............|/+----\|.....................|
##+...........+#...................||&n&}#||.....................|
|...........||...................||nnnn}||.....................|
|...........|\-+++---------+-----/\--+--/\------------###---+--/
|...........+## # /---#-----------------\ ####
+...........| /+--\ |.....................| ++--\
#-----+-+---/ |...|##+.................#...+####+#}}|
/+\ /--#-#---------------\ |...|# |.....................| +#}}|
|.| |....................| \---/# |..................g..| \+--/
|.| |....................| /--\# \+------++------------/ #
\-/ |...........F........+##+..|# # ## /-------------+\
|.................T..| |.>|################+........n.....|
\------+-------------/ \+-/# # ###########+..}n.&...#n.#.+##
# /-----------#--#--+-\+---++-\ |.&..n.........|
/---------+---\ |...................#+...t..+##+.n{........n..|
|.............+#+...................||......| \--------------/
|...L.{.......| \-------------------/\----+-/
\-------------/ #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 3.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 1 (Haphazard)
# # # # ###############
# //-----------\ ## # #
# |............| # # ### /+---\ ## #
|............| # # # ## ##+....| # # #
++...........| # ## # # |<...| # ##
# # \\-+---------/ # /--+---\# # |....+##########
# # # # #############+.Y'.&.+\# # |....| # #
/-------+-\ # # |..o....|## ## \-+--/ #
|F._T...Uq|# # # # |E.X..B.| ### # # ###########
|Ez.F.LoEU| ### \----+-// # # # # #
|.Uq..>...| # # # ## # # ## # #
\---------/ # # ### # ##/+-\ # #
# ## # # # # ### /+|.g|-\ #
# /-+---------\ /+---\# # ## |..E...| # #
# /----------|...........| # |q..#|\ ## |...f..| # #
# # |..........+...........| |.H...| # |...F+.| #
|......................| |P&.&.| # \-\+-/-/ #
\----------\-----------/ # \-.+..| # # # #
# /----\# /---\\ #\-+--/ # # #
# /|....+##########+`.`.| # ## # # /--+-----\\ #
# ++o..m| |...++ ## |........++ #
# |.H&.&| |`.`|/###################+.........| #
|....-/ \---/ # # #|J.E......| #
# \----/ ###################\--------// #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
Using layout style 2.
Placing corridors (style 2)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 2 (Systematic)
# ---------------- # -------------
-------------------- # ## ---+.+++++++++++++.| # |...........|
|E......++++++++++++- ## |...| ...E...E....|+####+...........|
|......|@...._...<.+| ### |...|g........&...|+####+##.....z...|
#+.&....+....#######++###### |...|.+-----+-----|---+--------++++++E
|......--------+-+-++#######+###+#+###.....'PE+&+E++-.+--.-+-. ##
|...........#+#####+---++++----+--+-+-|------+||'|'.m|...+#..+###
-------------|---+-+#.|.q+..+++.++...+|.......+--|+--+...|...|###
-....#+##+.#+.....+..++-+.++++++-+-++.......+...+ #
----+-++++---...}-|--#}}||.........|-+++-+--+-+++ #
# # # -...++++.---+-+++++++++++++.+--+++--#### #
# +-----+--.|...#...####...#.#.|# # ###### #
# |.&......||..................|# # ######
# #########+........+++++++-----+-----++-# # -++++##
# ## ###+........+ ###### |#..###+##########+g..+##
## # |........| # ###|#.....| ## # |#a.+##
# # # ---------- ## -+-+--------++--+----#..|#
# ## ### ##########+...................+#.>|#
## # #--+---+++--.................+#t.|#
###### ##+.#...#.|.|.................|+++-#
# # ## ## |.#---+------------+---------######
########################+.#+.E.###+#########+########### #
# ###########+..|.E....|.........| ## ## ##
# ### --------------------- ## ###
nathan@warthog:~$
Jonadab the Unsightly One
Dec 15, 2012, 5:36:37 PM12/15/12
to
Here's some more sample output. These all showcase the new hybrid
corridor style.
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
/--------------------------------\
#####+|................................+##
# ++................................|##
# ++................................|###
/-+--\ |................................-/# #
|hhhE| \---++------+----------------+-+-/ # +-------\ ####
|.Ohh| ## /----+---\ ## # +...}..}|-\ ## #
|hhhh| #|......X.| /+----\##|}......+.|########
\--+-/ #+........| |EBE.E|+#|}........| ##
### #######|........| |.EH.|++ +..}......| #####
# # # |........+ #+.EE.E.| |.........| /-+--+\
# # # \++------+ #+-----// \--.+.....| |..q..|
# # # ## \-+-----/ |.qm..|
### # # |qqq..|
## //-----++-----------------------------\ |.>q..|
# ## ++....................................| |.fg..|
###++..........m.........................+### ###|... q|
# |.............................<.......| # ###+----+/
# \\+---------------+-------------------/ # ## #
# # # # ## # #
## ## #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 2.
Placing corridors (style 4)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 4 (Hybrid)
# # # ##################+----------
## ### ## # ## #####|.........|
### ## ## # # # +-++-##### # ###|.........|
# ################ ---------------+}.}|# ## # # #+.........|
# # #####|z.q.z...oqzz..|+#}|# # # # ------++---
# # # ---++##++++++++++++-+..zzF+|.}+ # # # # # ## #
# ####|...+##|.n#|&nn{&nn}+z.z..||#}| # # # ------++---
# ##+.-+++++###+..#..---+-+----+--- ---+-----+-+#+.......gE|
-+-++++-+-+-+----+-.-.------+-# |}.z....---|-|---......|
# +..E+++}+.-+---....|{+######.+## |..&..}|...+.|..|..E...|
# # #|..||.|+|+hEqEE+...-+|-...Y.<| ## |.m.w..+...|#--+-+--+---
# ##|x.|--+m+F---+++++-.--|#.....+####+}..}..|...+++-+++--+----
# # -+--+-+-----+-..###+FO+------- +-----++----#...+.......|
## ## # # ---+++--+++++---- # # ---++-+-++.......|
# # # # # +..##+..|.......+##############+...#........|
# ## ## # -------+--+-+++--.......++++++-- ## |............|
# ## # # ## |.......+......+##......|+`.`.`| ### --+++++---+-+-
# # # # |.......|......+#......-+.-----|--# ### ### ####
# #---+---++++++-----..---++--|++-----+-+`E`..+#+##### #### ####
# #+--+----+---|....+.......#.|### ##||..-+-|--.|########## ## ##
###|...q.&.....-----++-----+-----++--++---q#+##.+# #-++--+--## #
###|.'.........+....+## |.........z||&..+#+...|## +.F....+# #
###+------------+----#####+..........-----|+-+---####+...>..|######
# # # -----------------## # #-------- #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 2.
Placing corridors (style 4)...
Layout Style: 2 (Overlapping Rectangles)
Corridor Style: 4 (Hybrid)
# ########## ## ##
### ### -+---+--## #### ######################
# # #-++++++---+-++++-- ### ######### #
# # |.#+.+......+.<.#+# ### # # #
########+.#|.---+-+-|....+########################## #
---+----++++----.......+---++# ## # ##### # #
|.........#--.---+------+----++# --+----+-+-+------ # #
#|.........#..|...|............+## |....}....}......| # #
|.....##.#...|...+............|####+.....}..........| # ##
------+-+----|----------......+####+.......}........| # ###
#####+........-..........----+++### +++-----+-+------- # # #
# |......--.+--+-+--+-.++++---## # ### ##### # --+- #
# |......|#|.`..`..`.++......|# ## ## ### # # | E| #
#####+......+#+`..`..`..|+......+########### ### # # |&X| #
# -------++|+++++------......|# ### ### # |&.| #
#--+--+-----+++.................+## ####### #####|>.| #
#+.#.#...z....----+--++---+------ # ####+-+-----##+--- #
#|-+-++#E...q....#...| # ## ## +......+# #
#+|-++|-----+---+---------+----------+---------+|......| #
##+...|## # ##+........}....}}..........|......+#########
##|...+## # ### |.........................+......+#########
##+...+#### # ### |.........}.._......}.....-+---+-+#########
##+----###############+-------------------------+################
#### # # ## ## +--------------+##
/-+--+-\ # # ## # /|..............+##
## |P.P..P+ # # ## # |.............J.|##
###|P.....|-\ ## # # /------+-----\ ++..............| ##
###+.P......| ## # # |............| |...++.+.......-/ ##
# #|....P...| ## # #######+............| \---+-+--------/ #
###+......|-/ # # |............| # #
|......| ## # |............+####### #
\-+-+-++ ### # |............| ### #
## # # ## # \-++---------/ ### #
/--+---+-------+--+--+\-\ # ## #
|.......................| # ## #
|.......................| # ## #
|...........}...........| # ## ##
|.......................| /--/------+---\ ##
|.....................+.| |............{| ##
|.......................| |.............| ###
|.>.....................| |.............+### ###
|.....................+.| |.......<.....| ### ###
|.....................|-/ \--|..........|## # ###
\---------+------+----/ # #|..........+# ####
#####################################+..........| ###
# \----------/ ##
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 1.
Placing corridors (style 4)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 4 (Hybrid)
################### ## #####################
##/------\ /------+----\###/---------\/--\#/---------\#/----\#
# ##+.. ...| |...........|# #|...&.....#+..|#+.....h...+#+EEdE|#
# ##|f.....+#|...........+###+.........#|..+#|.........|#|'.&.+#
#####|g.&.'.+#+...........|###|....g....|\+-/#\+-+------+#\+--+/#
#####+-+----/#\#+##----+--## #\++-+++---/ #####--#-------###+-# #
+--+-+++---\####/-++++-+\/++----####-------\##|.m.............+ #
+.&........+####+..}}...++....}............|##|.......&.......| #
|..........+####+.}.}...|+..........}....}&+##+&..............|##
\-#-+------#### \-+---+-/|.<...............| \---+-----------+ #
/-++-+\#----+-+---#---+\###----+--------########### # #
|.....++...............++---------\ /----+\############## # #
|...g.|+...............|+`.`.`.`.`|#+..F..+# ## # #
\-+-+-+#----------+++--#+.`.`.`.`.|#|.....|##/------------+-\ # #
####/#-#--------###--\ #\--++---+-+#\--+--+# |..............| ###
# #+..............#.| # ####/-#-----#+--+-#|..............|/+-+\
####|............&...| # ## #|.............#|..............||E{&|
#\+----###+---#--#/ #######+.............|++----+----+---/|q>q|
#########++---+-+----+-++-\ #|.............| # # # \---/
#### ###|....&...H.......| ##|.............| # /-+------+------\
#/+--++-++............f...+ ##\-------------/####|...............|
|......++..h.f.g.........+ # # #+...............|
|......||T...........Y...| ###################|...............|
\------/\----------------/ # \---------------/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
## ### |....|
# ## ## # |....|
# # ## ### |....+#
|.J.| # # /++----\### #|....| #
|E..| # #|.&.LL.+#+------\\ ###|....| #
# #####+&a|/ # +..&...| |...&WW.| #####+....| #
# \-+/ # |.j..g.+ |q......| +++###|....| #
# ## /------+---\ |L.a.n.|#|.f....++##++.|\ |....| #
# ###+..........|\ |......|#+W.....++ |...| \--+-/ #
# |...........| |....F.|#+.....g|###|...| # # #
/+\ |...........| |.L.H..+#|.&....| |...| # ## #
/|.|\ |...........| #+......| |..W.h.| |...| # ### #
|...| |...........+###\------/ |......| |...| # # #
|...| |...........| |.oW..W| |...| #/---\###
|...| |...........| \------/ |._++ #|..>|\##
|...+ ###+..........|/ |.<.| #|....|##
|..++### \----------/ ++.|/ #|....+ #
|...| ##\++######+...++##
\|.+/ ## ## #\-+..|##
\-/#####################################################++--+##
corridorstyle 4
Using layout style 1.
Placing corridors (style 4)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 4 (Hybrid)
# ########### ####+-------------------\ # #
/-----\ # # # # ### |...................|/----------\
# |.....+######################+...................#+.h..P.....|
#|.....|#----+---------+-----#|...................||}.}.}...}.|
|.....+|....................|+..............|....||......J.}.|
\----+/+....................|\--------------+--+-/\+--+---+-+/
####|....................+ # ## # #/-+##\
/-+-+\|...............f....| ## ## # +....|
|....||........<...........|/------\ /--+-+------+---\|....|
##+....||....................|+......| |...............||....|
# |....||....................+|......| |...............|+....|
#########################+----/\------+##+...............+|....|
/---+-\## /----+--+++-\ # |...h...........||....|
#|}>|..|###|.........E.+### # \---------++----+|....|
|&....| #|...........+# ####### ## # #-+--+
#|.X...| +&..........|#+------++++++---------\ ## ## #
\+----+ \---------+-+#+.........|...........|/-----++----+-\#
### /+-+\ ## |.....................||.............|#
# |...|/------\ # \--+++-+----+-+-+-#--+/|.............|#
# # #+..E||....#.+#-----------##+----+-+\+-+--+ |.............|#
## #+...||......++.....................#+}.}}+#+{............+#
# |...||......++.....................||}}..|#\-------------/##
####+---/\------+|.....................||}.}}|#################
# \---------------------/\----/
Using layout style 1.
Placing corridors (style 4)...
Layout Style: 1 (Dense Room Packing)
Corridor Style: 4 (Hybrid)
/-------\ ############### # /--------------\##########
|.......| # # ## |..............|####/-------\
# |.......+## # # #|..............|# ##+.......|
##|....&..+#++------------+------\/+-\+..............|# ##|.......|
##+....{..|#|.&................tE+|NE+|..............+####+.......|
####+-#+++/#\--+-++++------------/+gh||..............| |{......|
#/-+-\#/++-#---+----#####-\ |gP+#..............| #+.......|
#|...+#|..................+# \+-/#---------+----/ ##\-+-+-+-/#
#|...| |..........{....>..|##### ## # ## ### ######
#\+++/ |..................| +++++--+-----------+--++-----\## ###
# ### |..................| |.}..........................| #####
#/+++\ +-----------#+-----/ |............................|#/-+-+\
#|...|## /-+-+------\ |.....q......................+#+..t.|
|...+# ##+..........+###+...g........................| |....|
\+-+/ ### |..<.......|###|...........a................|#\----/
#/--------+ \----+-+--+/ +--------+--+++++++-+++++----/
#|........| #/----#--##--\ # ######## # ####
# #|........|# #+...........| #++++++----+------+--\ ##/-+++++--\
#|........|###|..|........+###+...................| #+X}XXBd..|#
#|........|# #\+--###+########|...................| #|dX.}..XX|#
#|........| +++++#++-+---\ #\-----+-------------/ +UX.YXXHw|#
#++-+-----/#|...++._.....+######## # \----+---+##
##########+}..+|.......+ # #################################
\---/\-------/ # # ##
nathan@warthog:~$
corridor style.
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
#####+|................................+##
# ++................................|##
# ++................................|###
/-+--\ |................................-/# #
|hhhE| \---++------+----------------+-+-/ # +-------\ ####
|.Ohh| ## /----+---\ ## # +...}..}|-\ ## #
|hhhh| #|......X.| /+----\##|}......+.|########
\--+-/ #+........| |EBE.E|+#|}........| ##
### #######|........| |.EH.|++ +..}......| #####
# # # |........+ #+.EE.E.| |.........| /-+--+\
# # # \++------+ #+-----// \--.+.....| |..q..|
# # # ## \-+-----/ |.qm..|
### # # |qqq..|
## //-----++-----------------------------\ |.>q..|
# ## ++....................................| |.fg..|
###++..........m.........................+### ###|... q|
# |.............................<.......| # ###+----+/
# \\+---------------+-------------------/ # ## #
# # # # ## # #
# # # # ## # #### #
### ########################################
## ## #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 2.
Placing corridors (style 4)...
Layout Style: 2 (Overlapping Rectangles)
# # # ##################+----------
## ### ## # ## #####|.........|
### ## ## # # # +-++-##### # ###|.........|
# ################ ---------------+}.}|# ## # # #+.........|
# # #####|z.q.z...oqzz..|+#}|# # # # ------++---
# # # ---++##++++++++++++-+..zzF+|.}+ # # # # # ## #
# ####|...+##|.n#|&nn{&nn}+z.z..||#}| # # # ------++---
# ##+.-+++++###+..#..---+-+----+--- ---+-----+-+#+.......gE|
-+-++++-+-+-+----+-.-.------+-# |}.z....---|-|---......|
# +..E+++}+.-+---....|{+######.+## |..&..}|...+.|..|..E...|
# # #|..||.|+|+hEqEE+...-+|-...Y.<| ## |.m.w..+...|#--+-+--+---
# ##|x.|--+m+F---+++++-.--|#.....+####+}..}..|...+++-+++--+----
# # -+--+-+-----+-..###+FO+------- +-----++----#...+.......|
## ## # # ---+++--+++++---- # # ---++-+-++.......|
# # # # # +..##+..|.......+##############+...#........|
# ## ## # -------+--+-+++--.......++++++-- ## |............|
# ## # # ## |.......+......+##......|+`.`.`| ### --+++++---+-+-
# # # # |.......|......+#......-+.-----|--# ### ### ####
# #---+---++++++-----..---++--|++-----+-+`E`..+#+##### #### ####
# #+--+----+---|....+.......#.|### ##||..-+-|--.|########## ## ##
###|...q.&.....-----++-----+-----++--++---q#+##.+# #-++--+--## #
###|.'.........+....+## |.........z||&..+#+...|## +.F....+# #
###+------------+----#####+..........-----|+-+---####+...>..|######
# # # -----------------## # #-------- #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 2.
Placing corridors (style 4)...
Layout Style: 2 (Overlapping Rectangles)
# ########## ## ##
### ### -+---+--## #### ######################
# # #-++++++---+-++++-- ### ######### #
# # |.#+.+......+.<.#+# ### # # #
########+.#|.---+-+-|....+########################## #
---+----++++----.......+---++# ## # ##### # #
|.........#--.---+------+----++# --+----+-+-+------ # #
#|.........#..|...|............+## |....}....}......| # #
|.....##.#...|...+............|####+.....}..........| # ##
------+-+----|----------......+####+.......}........| # ###
#####+........-..........----+++### +++-----+-+------- # # #
# |......--.+--+-+--+-.++++---## # ### ##### # --+- #
# |......|#|.`..`..`.++......|# ## ## ### # # | E| #
#####+......+#+`..`..`..|+......+########### ### # # |&X| #
# -------++|+++++------......|# ### ### # |&.| #
#--+--+-----+++.................+## ####### #####|>.| #
#+.#.#...z....----+--++---+------ # ####+-+-----##+--- #
#|-+-++#E...q....#...| # ## ## +......+# #
#+|-++|-----+---+---------+----------+---------+|......| #
##+...|## # ##+........}....}}..........|......+#########
##|...+## # ### |.........................+......+#########
##+...+#### # ### |.........}.._......}.....-+---+-+#########
##+----###############+-------------------------+################
corridorstyle 4
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
########### ################ #
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
#### # # ## ## +--------------+##
/-+--+-\ # # ## # /|..............+##
## |P.P..P+ # # ## # |.............J.|##
###|P.....|-\ ## # # /------+-----\ ++..............| ##
###+.P......| ## # # |............| |...++.+.......-/ ##
# #|....P...| ## # #######+............| \---+-+--------/ #
###+......|-/ # # |............| # #
|......| ## # |............+####### #
\-+-+-++ ### # |............| ### #
## # # ## # \-++---------/ ### #
/--+---+-------+--+--+\-\ # ## #
|.......................| # ## #
|.......................| # ## #
|...........}...........| # ## ##
|.......................| /--/------+---\ ##
|.....................+.| |............{| ##
|.......................| |.............| ###
|.>.....................| |.............+### ###
|.....................+.| |.......<.....| ### ###
|.....................|-/ \--|..........|## # ###
\---------+------+----/ # #|..........+# ####
#####################################+..........| ###
# \----------/ ##
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 1.
Placing corridors (style 4)...
Layout Style: 1 (Dense Room Packing)
################### ## #####################
##/------\ /------+----\###/---------\/--\#/---------\#/----\#
# ##+.. ...| |...........|# #|...&.....#+..|#+.....h...+#+EEdE|#
# ##|f.....+#|...........+###+.........#|..+#|.........|#|'.&.+#
#####|g.&.'.+#+...........|###|....g....|\+-/#\+-+------+#\+--+/#
#####+-+----/#\#+##----+--## #\++-+++---/ #####--#-------###+-# #
+--+-+++---\####/-++++-+\/++----####-------\##|.m.............+ #
+.&........+####+..}}...++....}............|##|.......&.......| #
|..........+####+.}.}...|+..........}....}&+##+&..............|##
\-#-+------#### \-+---+-/|.<...............| \---+-----------+ #
/-++-+\#----+-+---#---+\###----+--------########### # #
|.....++...............++---------\ /----+\############## # #
|...g.|+...............|+`.`.`.`.`|#+..F..+# ## # #
\-+-+-+#----------+++--#+.`.`.`.`.|#|.....|##/------------+-\ # #
####/#-#--------###--\ #\--++---+-+#\--+--+# |..............| ###
# #+..............#.| # ####/-#-----#+--+-#|..............|/+-+\
####|............&...| # ## #|.............#|..............||E{&|
#\+----###+---#--#/ #######+.............|++----+----+---/|q>q|
#########++---+-+----+-++-\ #|.............| # # # \---/
#### ###|....&...H.......| ##|.............| # /-+------+------\
#/+--++-++............f...+ ##\-------------/####|...............|
|......++..h.f.g.........+ # # #+...............|
|......||T...........Y...| ###################|...............|
\------/\----------------/ # \---------------/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
corridorstyle 4
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
# ## /----\
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
## ### |....|
# ## ## # |....|
# # ## ### |....+#
# ## ## ## |....|##
/--\\ # ### #### # #+....| ###
|.J.| # # /++----\### #|....| #
|E..| # #|.&.LL.+#+------\\ ###|....| #
# #####+&a|/ # +..&...| |...&WW.| #####+....| #
# \-+/ # |.j..g.+ |q......| +++###|....| #
# ## /------+---\ |L.a.n.|#|.f....++##++.|\ |....| #
# ###+..........|\ |......|#+W.....++ |...| \--+-/ #
# |...........| |....F.|#+.....g|###|...| # # #
/+\ |...........| |.L.H..+#|.&....| |...| # ## #
/|.|\ |...........| #+......| |..W.h.| |...| # ### #
|...| |...........+###\------/ |......| |...| # # #
|...| |...........| |.oW..W| |...| #/---\###
|...| |...........| \------/ |._++ #|..>|\##
|...+ ###+..........|/ |.<.| #|....|##
|..++### \----------/ ++.|/ #|....+ #
|...| ##\++######+...++##
\|.+/ ## ## #\-+..|##
\-/#####################################################++--+##
corridorstyle 4
Using layout style 1.
Placing corridors (style 4)...
Layout Style: 1 (Dense Room Packing)
# ########### ####+-------------------\ # #
/-----\ # # # # ### |...................|/----------\
# |.....+######################+...................#+.h..P.....|
#|.....|#----+---------+-----#|...................||}.}.}...}.|
|.....+|....................|+..............|....||......J.}.|
\----+/+....................|\--------------+--+-/\+--+---+-+/
####|....................+ # ## # #/-+##\
/-+-+\|...............f....| ## ## # +....|
|....||........<...........|/------\ /--+-+------+---\|....|
##+....||....................|+......| |...............||....|
# |....||....................+|......| |...............|+....|
#########################+----/\------+##+...............+|....|
/---+-\## /----+--+++-\ # |...h...........||....|
#|}>|..|###|.........E.+### # \---------++----+|....|
|&....| #|...........+# ####### ## # #-+--+
#|.X...| +&..........|#+------++++++---------\ ## ## #
\+----+ \---------+-+#+.........|...........|/-----++----+-\#
### /+-+\ ## |.....................||.............|#
# |...|/------\ # \--+++-+----+-+-+-#--+/|.............|#
# # #+..E||....#.+#-----------##+----+-+\+-+--+ |.............|#
## #+...||......++.....................#+}.}}+#+{............+#
# |...||......++.....................||}}..|#\-------------/##
####+---/\------+|.....................||}.}}|#################
# \---------------------/\----/
Using layout style 1.
Placing corridors (style 4)...
Layout Style: 1 (Dense Room Packing)
/-------\ ############### # /--------------\##########
|.......| # # ## |..............|####/-------\
# |.......+## # # #|..............|# ##+.......|
##|....&..+#++------------+------\/+-\+..............|# ##|.......|
##+....{..|#|.&................tE+|NE+|..............+####+.......|
####+-#+++/#\--+-++++------------/+gh||..............| |{......|
#/-+-\#/++-#---+----#####-\ |gP+#..............| #+.......|
#|...+#|..................+# \+-/#---------+----/ ##\-+-+-+-/#
#|...| |..........{....>..|##### ## # ## ### ######
#\+++/ |..................| +++++--+-----------+--++-----\## ###
# ### |..................| |.}..........................| #####
#/+++\ +-----------#+-----/ |............................|#/-+-+\
#|...|## /-+-+------\ |.....q......................+#+..t.|
|...+# ##+..........+###+...g........................| |....|
\+-+/ ### |..<.......|###|...........a................|#\----/
#/--------+ \----+-+--+/ +--------+--+++++++-+++++----/
#|........| #/----#--##--\ # ######## # ####
# #|........|# #+...........| #++++++----+------+--\ ##/-+++++--\
#|........|###|..|........+###+...................| #+X}XXBd..|#
#|........|# #\+--###+########|...................| #|dX.}..XX|#
#|........| +++++#++-+---\ #\-----+-------------/ +UX.YXXHw|#
#++-+-----/#|...++._.....+######## # \----+---+##
##########+}..+|.......+ # #################################
\---/\-------/ # # ##
nathan@warthog:~$
Pasi Kallinen
Dec 16, 2012, 12:23:27 PM12/16/12
to
Jonadab the Unsightly One <jonadab.the...@gmail.com> wrote:
> Here's some more sample output. These all showcase the new hybrid
> corridor style.
You're spending a lot of time and energy on code no-one can use
> Here's some more sample output. These all showcase the new hybrid
> corridor style.
with NetHack without spending more time and energy converting it to C.
You might be better off with rec.games.roguelike.development
where some perl-roguelike would benefit with this.
--
Pasi Kallinen
pa...@alt.org
http://bilious.alt.org/ -- NetHack Patch Database
Janis Papanagnou
Dec 17, 2012, 5:35:39 AM12/17/12
to
On 16.12.2012 18:23, Pasi Kallinen wrote:
> Jonadab the Unsightly One <jonadab.the...@gmail.com> wrote:
>> Here's some more sample output. These all showcase the new hybrid
>> corridor style.
>
> You're spending a lot of time and energy on code no-one can use
> with NetHack without spending more time and energy converting it to C.
I agree that perl probably isn't a good base for that purpose. I am
> Jonadab the Unsightly One <jonadab.the...@gmail.com> wrote:
>> Here's some more sample output. These all showcase the new hybrid
>> corridor style.
>
> You're spending a lot of time and energy on code no-one can use
> with NetHack without spending more time and energy converting it to C.
wondering, though, what the best way would be to provide such new
map generation code. Certainly final code in form of a fitting patch
would be best. But last time I inspected Nethack's maps and dungeons
implementations I got horrified by that code; I don't recall to have
seen a clean interface. OTOH the constants and variables I've seen
used to handle the map and screen boundaries reminded me program
code from the 1970's. That code quality at least repelled me from
adding the Sewers[*] as new map type many years ago. Is there some
identifiable interface[**] that I've missed that can be used?
Janis
PS: I had also implemented some "Big Cave" level, based on existing
source code - something like the "Bigroom" levels but with amorphous
shape -, but lacking to identify a clean interface it was an ugly hack,
to say the least. I wonder whether that variant (what was it's name?
is it still alive?) that focuses, instead of new features, on a better
code base would support adding new dungeon types in a better way?
[*] That code is still unused as C++ source code on my disk. This
might be a better base than perl to convert to C, but anyway there
will be some adaption work to do.
[**] I don't mean the level compiler for special levels, rather one
appropriate to embed a new standard dungeon topology.
Pasi Kallinen
Dec 17, 2012, 10:49:43 AM12/17/12
to
Janis Papanagnou <janis_pa...@hotmail.com> wrote:
>
> [snip]
To make adding the map generation routine easier, code it
in plain C and use simple routines to set and get "terrain"
in a simple two-dimensional map array. For example (not tested):
#define TER_WALL ' '
#define TER_FLOOR '.'
#define TER_CORRIDOR '#'
#define COLNO 80
#define ROWNO 21
char map[COLNO][ROWNO];
void
map_clear(char ter)
{
memset(map, TER_WALL, sizeof(map));
}
void
map_set(int x, int y, char ter)
{
map[x][y] = ter;
}
etc.
UnNetHack, OTOH, does make it slightly easier to add different
level generator types; see splev_initlev() in sp_lev.c
>
> [snip]
> Is there some
> identifiable interface[**] that I've missed that can be used?
>
> Janis
>
> PS: I had also implemented some "Big Cave" level, based on existing
> source code - something like the "Bigroom" levels but with amorphous
> shape -, but lacking to identify a clean interface it was an ugly hack,
> to say the least. I wonder whether that variant (what was it's name?
> is it still alive?) that focuses, instead of new features, on a better
> code base would support adding new dungeon types in a better way?
>
> [*] That code is still unused as C++ source code on my disk. This
> might be a better base than perl to convert to C, but anyway there
> will be some adaption work to do.
>
> [**] I don't mean the level compiler for special levels, rather one
> appropriate to embed a new standard dungeon topology.
>
No, there isn't any such interface.
> identifiable interface[**] that I've missed that can be used?
>
> Janis
>
> PS: I had also implemented some "Big Cave" level, based on existing
> source code - something like the "Bigroom" levels but with amorphous
> shape -, but lacking to identify a clean interface it was an ugly hack,
> to say the least. I wonder whether that variant (what was it's name?
> is it still alive?) that focuses, instead of new features, on a better
> code base would support adding new dungeon types in a better way?
>
> [*] That code is still unused as C++ source code on my disk. This
> might be a better base than perl to convert to C, but anyway there
> will be some adaption work to do.
>
> [**] I don't mean the level compiler for special levels, rather one
> appropriate to embed a new standard dungeon topology.
>
To make adding the map generation routine easier, code it
in plain C and use simple routines to set and get "terrain"
in a simple two-dimensional map array. For example (not tested):
#define TER_WALL ' '
#define TER_FLOOR '.'
#define TER_CORRIDOR '#'
#define COLNO 80
#define ROWNO 21
char map[COLNO][ROWNO];
void
map_clear(char ter)
{
memset(map, TER_WALL, sizeof(map));
}
void
map_set(int x, int y, char ter)
{
map[x][y] = ter;
}
etc.
UnNetHack, OTOH, does make it slightly easier to add different
level generator types; see splev_initlev() in sp_lev.c
Jonadab the Unsightly One
Dec 17, 2012, 8:26:15 PM12/17/12
to
On Dec 16, 12:23 pm, Pasi Kallinen <pa...@alt.org> wrote:
> You're spending a lot of time and energy on code
> no-one can use with NetHack without spending
> more time and energy converting it to C.
You underestimate how much easier Perl is
> You're spending a lot of time and energy on code
> no-one can use with NetHack without spending
> more time and energy converting it to C.
to write than C. I'm just playing around with
possible algorithms here. If I had to do this
in C, I wouldn't be playing around with
anywhere near as many different possible
code paths, any one of which might end up
just getting scrapped.
Jonadab the Unsightly One
Dec 17, 2012, 8:39:13 PM12/17/12
to
On Dec 17, 5:35 am, Janis Papanagnou <janis_papanag...@hotmail.com>
wrote:
> I agree that perl probably isn't a good
> base for that purpose.
These are just quick-and-dirty algorithm demos.
Most of the effort involved in creating them is
going into deciding how things should work
in principle. The actual code is easy.
> I am wondering, though, what the best way
> would be to provide such new map generation
> code. Certainly final code in form of a fitting
> patch would be best.
If I reach the point where I am convinced that
I have a map-generation algorithm tweaked
to the point where it doesn't need very much
additional tweaking, then attempting to
implement it as a patch would be the next
step, yes.
But there's no point in my trying to implement
it in C if it needs conceptual overhauls to get
the levels to come out right. That would be a
HUGE waste of effort.
> But last time I inspected Nethack's maps
> and dungeons implementations I got horrified
> by that code;
Yes, that was my reaction as well. However,
I've been reading through it some more and
taking notes on some of how it works, and I
am beginning to understand parts of it...
> but lacking to identify a clean interface ...
> I wonder whether that variant that focuses,
level code (including the level file format).
However, SporkHack is a variant mainly
focused on making gameplay changes.
You may be thinking of NetHack4 (or
NitroHack, which is related), but it makes
few changes to level generation, if any.
wrote:
> I agree that perl probably isn't a good
> base for that purpose.
Most of the effort involved in creating them is
going into deciding how things should work
in principle. The actual code is easy.
> I am wondering, though, what the best way
> would be to provide such new map generation
> code. Certainly final code in form of a fitting
> patch would be best.
I have a map-generation algorithm tweaked
to the point where it doesn't need very much
additional tweaking, then attempting to
implement it as a patch would be the next
step, yes.
But there's no point in my trying to implement
it in C if it needs conceptual overhauls to get
the levels to come out right. That would be a
HUGE waste of effort.
> But last time I inspected Nethack's maps
> and dungeons implementations I got horrified
> by that code;
I've been reading through it some more and
taking notes on some of how it works, and I
am beginning to understand parts of it...
> but lacking to identify a clean interface ...
> I wonder whether that variant that focuses,
> instead of new features, on a better code
> base would support adding new dungeon
> types in a better way?
SporkHack has some improvements in the
> base would support adding new dungeon
> types in a better way?
level code (including the level file format).
However, SporkHack is a variant mainly
focused on making gameplay changes.
You may be thinking of NetHack4 (or
NitroHack, which is related), but it makes
few changes to level generation, if any.
Janis Papanagnou
Dec 17, 2012, 9:17:25 PM12/17/12
to
On 17.12.2012 16:49, Pasi Kallinen wrote:
> Janis Papanagnou <janis_pa...@hotmail.com> wrote:
>>[Sewers dungeon type]
Thanks. Following your suggestion, I've now rewritten the C++ Sewers
source code in C (which was easy since those code primitives already
existed in similar form in the old sources). The new source code is
now available at http://nh.gridbug.de/sewers.c (though I'm not sure
what to do with it now).
Janis
> Janis Papanagnou <janis_pa...@hotmail.com> wrote:
>>[Sewers dungeon type]
>> [*] That code is still unused as C++ source code on my disk. This
>> might be a better base than perl to convert to C, but anyway there
>> will be some adaption work to do.
>
>> might be a better base than perl to convert to C, but anyway there
>> will be some adaption work to do.
>
> To make adding the map generation routine easier, code it
> in plain C and use simple routines to set and get "terrain"
> in a simple two-dimensional map array. For example (not tested):
> [...]
> in plain C and use simple routines to set and get "terrain"
> in a simple two-dimensional map array. For example (not tested):
Thanks. Following your suggestion, I've now rewritten the C++ Sewers
source code in C (which was easy since those code primitives already
existed in similar form in the old sources). The new source code is
now available at http://nh.gridbug.de/sewers.c (though I'm not sure
what to do with it now).
Janis
Chris
Dec 18, 2012, 3:38:37 AM12/18/12
to
My 2 zorkmids:
I like the overlapping rectangle designs. Most of them look like larger, multi-room structures within the dungeon.
I also like some of the dense-packed rooms with lots of corridors, especially this one:
I don't think the non-rectangular rooms are... non-rectangular enough. L and U shapes should be more common.
I like the overlapping rectangle designs. Most of them look like larger, multi-room structures within the dungeon.
I also like some of the dense-packed rooms with lots of corridors, especially this one:
# ## # # /-------\ /----------------\ #/--\
# /---+---\ |.......| |................+##+.E+#
#/++---\ |.......+#############+.......| |................| |..|
|.B...+###+.......| # /---\ +--+----/ |................+##+++/
|.E...| \+--+---/ ####|...| ##########+................| ##
#+.....| /#--#----\ # ##|...+########## \-------+--------/ ###
|.....| # |..E.....|/+--+|...| ## /+---++---\ # /----++++E
\-++--+###+........#+o.&+#...| ## |.........| # ####+.......|
# ## ##|........#|&f.|\#--/ ## |.........|/----+---+--\|.......|
/+++---\#|....&...#\---//-+---++\|{........||...}.......||.......|
##+######+#+-+------# # |..&...J+\---------/|}..........||.......|
# \------/####--\ ######+...{&..|#/------\ |...........|\---+---/
# +..t.| ### \-------+#+......| |.........}.| /--#---\
#/----\ +{#B.| #/+\ /----------# |......| \-----------/ |g.....|
#|....+####|...Y| #|#| |.......j..+ \----+-/ # # +.&....|
#|....| #|oL..| +.| |...&......|# /---#-----------\ ###+......|
#\----/ #\----/ +.+#+.........g+##+......#........+######+...o..|
## # # +.| |..........| +...............| # \--#---/
#/--------+-----\ \+/ \----+----+/ \#--------------/ /-------+\ #
#|..|...........| # # ### /-+-\ /--------\ |......B.|
#|..............|/--+#++----+----+-+ |...+#+........|# |.......>|
#|..............||DD+#D..D...DD....+#+...| |.....ET.| |...H....|
#+..............||DD||..D.DDD......|#++--/ \--------/ |........|
#\--------------/\--/\-------------/ ## \--------/
They look sort of like towns with multiple one-room dwellings.
# /---+---\ |.......| |................+##+.E+#
#/++---\ |.......+#############+.......| |................| |..|
|.B...+###+.......| # /---\ +--+----/ |................+##+++/
|.E...| \+--+---/ ####|...| ##########+................| ##
#+.....| /#--#----\ # ##|...+########## \-------+--------/ ###
|.....| # |..E.....|/+--+|...| ## /+---++---\ # /----++++E
\-++--+###+........#+o.&+#...| ## |.........| # ####+.......|
# ## ##|........#|&f.|\#--/ ## |.........|/----+---+--\|.......|
/+++---\#|....&...#\---//-+---++\|{........||...}.......||.......|
##+######+#+-+------# # |..&...J+\---------/|}..........||.......|
# \------/####--\ ######+...{&..|#/------\ |...........|\---+---/
# +..t.| ### \-------+#+......| |.........}.| /--#---\
#/----\ +{#B.| #/+\ /----------# |......| \-----------/ |g.....|
#|....+####|...Y| #|#| |.......j..+ \----+-/ # # +.&....|
#|....| #|oL..| +.| |...&......|# /---#-----------\ ###+......|
#\----/ #\----/ +.+#+.........g+##+......#........+######+...o..|
## # # +.| |..........| +...............| # \--#---/
#/--------+-----\ \+/ \----+----+/ \#--------------/ /-------+\ #
#|..|...........| # # ### /-+-\ /--------\ |......B.|
#|..............|/--+#++----+----+-+ |...+#+........|# |.......>|
#|..............||DD+#D..D...DD....+#+...| |.....ET.| |...H....|
#+..............||DD||..D.DDD......|#++--/ \--------/ |........|
#\--------------/\--/\-------------/ ## \--------/
I don't think the non-rectangular rooms are... non-rectangular enough. L and U shapes should be more common.
Jonadab the Unsightly One
Dec 18, 2012, 10:07:50 AM12/18/12
to
On Tuesday, December 18, 2012 3:38:37 AM UTC-5, Chris wrote:
> I don't think the non-rectangular rooms are...
> non-rectangular enough.
Hmmm... perhaps the offsets are too small in the
> I don't think the non-rectangular rooms are...
> non-rectangular enough.
average case?
> L and U shapes should be more common.
Hmmm... what about rooms with embedded
"pillars" (small sections of wall/rock
within the room)?
Janis Papanagnou
Dec 18, 2012, 10:17:36 AM12/18/12
to
where the solid rocks are houses (large rooms) and the channels are
the streets and narrow alleys, so the code structure can be reused.
I've now enhanced above linked code, now http://nh.gridbug.de/town.c,
to support both, sewers and towns, depending on the name of the
created executable. Samples can be found on http://nh.gridbug.de/
(nh.gridbug.de/sewers_sample.txt, nh.gridbug.de/town_sample.txt).
Janis
Jonadab the Unsightly One
Dec 18, 2012, 8:22:47 PM12/18/12
to
On Dec 18, 10:07 am, Jonadab the Unsightly One
How about this sort of thing?
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 1 (Haphazard)
##
## /---------------\ /--\
### |...............+#####+-|..|-\
# ### |...............|\####+....}.|
/-----------+---+-\ |................|####|..._.&+############
/|.D..DD..D........+######+.........>......|# |..R...| #
|........D.........| \-...............|# |......+############
|...D.D.D..........+######+|...............+####+......| #
|.D.........D......| \--+------------/ \-|..|-+############
|..............D..-+########################### \--/ #
\-+-------+-------/ #/--------\ #
# # /---------------\ #|g../--\.| #
## /-+-----\ |...............| #|../|-\|.| #
# |.......| |../--\.........+#########+.&|| ||.| #
### /----\..| |..| |.........|/-+-+-\ |..|| ||.| #
# | |..| |..\--/...../--\||.....| |.<|| ||.+######## #
## | |..+####+._.........| |||./---+# |..|\--/.| ####
##\----/..| |...........\--/||.| |##+..\--/..+###########
+.......| ##+...............||.| | \--------/ #
|.......| ##\---+--------+--/|.\---/ #
\-------/ ##### # |.....| #
# # |...w.| #
# # \-----/ #
###########################################
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 2 (Systematic)
/----------\ # /---------------------------\
|..........| # |...........................|
|..........|/-------+---------\|...........................|
|.../--\...||.................||...........................|
|...| |...||.................||...........................|
|...| |...||..../-++++++.....||...........................|
|...| |...+#....+##++##+.....||...................<.......|
|...| |...||....|# ||##|.....#+...........................|
\---\--/---/|....|# || #|.....||...........................|
|....\--/\--+.....||...........................|
|.................||...........................|
\-------------+---/\-----------------------+---/
## /---#----\
/-------------------+------------\ |........|
|................................| |........|
|................................| |........|
|......}.........................| |........|
|................................| |........|
|......................>.........| |........|
|................................| |........|
|................................| |........|
|................................| |........|
\--------------------------------/ |........|
layoutstyle 3
#### # |.........q..............|
# ## /----\ |........................| #
# + |....| #|...........g............+### # #
# /--|....|--\#+#...................E...| ### #
# #|..........+#+..............w.........| ## # #
# \--|....|--/ \---+--------------------/ ######
# |....| +########################/---------+--+----\ ##
## # #++---/ # # ########+ #|.................|# +##
## ## ## # ## # # ##/-+|.................|--\#
# # ## # ## # ## |.......................|#
######### # ## \--|.................|--/#
## # ### ## # ## |.................|# #
+--------+-+---------+--\ # ## # \---------+-------/# #
|.....>......./--\......| # +-----\ + /--/---\--+
|./--\........| |......| /-----+---|.....|---------\|..| |..|
|.| |........\--/......| |....................<....||..| |.q|
|.\--/.................m| |.........................|+..| |..|
\++----------+----------/ |.........................+|..\---/F.|
# # ## # \---------|.....|---------/|..q......|
# # # # \-----/ # \----+---+/
# # #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 3
Using layout style 3.
Placing corridors (style 3)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 3 (Directed)
/---------/--------\ /---\
|..................| |zw.|
# |..................| |...|
|j..........<......| |...|
\---------|........|/---|...| /------------------\
# |........||T...._@+ /|...............E..|
|........||.......+# +...&...............|
\-++---+-/|....E..+#####+...................|
# # ####+++++++-/## |..........h....g...|
# /------+++++++++------\ ## ## |... ......t...q...-/
|....d................| ## # \------++----------/
|.....................| ## ## ###
|.....................| ## ## ##
|.....................| ## # /++------\
\------|.......|+-----/ /---++++--+####+++......{.|
|.......|# |.........+ |..UO..g...|
# \-------/# #######+..o.|+---/ |..........|
/----------+++++++++\ |....| |..........|
# |}.................}| |....| |........--/
# |...>../-----\....E.| |...&| \--------/
|..}...| |.g..d.| |....|
|......| |To....| |....|
\------\-----/------/ \----/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 3
Using layout style 3.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
#
/--------------------------\ ##
|..........................| ####
|.........................&|+###### /--------\+ #
|...........................| # |......J.|----++###
|...........................| # |..............| #
\-........................x.| ## |..............| #
|..........................| /+------\ |>...&.........| #
\--------------------------/ |.......+#+&..........x..| #
/-----------------------\ |.......| |.HB.....|-----/ #
|.......................|+#/---------|.......| \--------/ #
|........................+#+.................|##### #
|........................| |.................+####################
\-..................<....| \---------\------+/ #
\-------------------+---/ # /-----\ #
/--\-#+----------------\ /-+--------\/-|.....| #
|g........L..}.........+###/------\nn.||.....}}| #
|ag|-------------------/ + |.n.++.......| #
#########+q.| /--------\ | |...||}}.}}..| #
# |.&| |.z..g..X|\ \------/..#||.....--/ #
# |.}+#########+.U.&..}fU| |..&&.#nnn.|\-----/ #
# |.&| |&E..P...H| \----------/ #
# \--/ \-.f..g...| #
#######################\--------/ #######
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 2 (Systematic)
# # # # # # ## # # # ##
# # ## # # ##
# # #### # # #########
# # # ## /-----+--\ ###############
# ###########+++--+-------|........|--+--+--+---+####
## # ## # |..................................+####
# ## |..................................+####
# # |..................................| ###
+---\ ## |..................................+####
+...| ## |..................................+####
# +...| ### |....................>.............+####
/-+...|-\ ## |..................................+####
|.#.....| ## |..................................|###
########+.......+########+..................................+####
# |.......+ ##|..................................+####
|....<..|# #+..................................|####
# # |.......|## +-----+--++--+........+-+++-+++++-++####
|.......| ### # # # ## +-+----++/#################
# |.......|# ## # ### ######## #####################
|.......+###############################################
\-+...|-/ # # ## ## ##### ##### ####################
# +...| # ## ########################################
|...+##################################################
\---/ # ## # ## ##### ## # ## # ###### ######
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 2 (Systematic)
/----------\ /---------\
#+..........| /------|.........|+-----\
|..........| |..................#d...|
|..........|----------------------\ |.E.....................|
|.......<.........................| +---++++.........|------/
\-+--+++++-/----------------------/##### \---------/
# # ## #/------------\
# # /--------\ /-+--+|............+++++++#######
# # /|........| |........................+
# # |.........+#####+.........O..............+
/--+------+-\ |.........| \-----|...U........|-----+
|..xLn......|\ \|........| ###############################
|........&...+###++-------/ # /----/-----\----\ ++++--\
|............| ### # |....| |....| |....F|
\-...........| # # # |....+#####+....+####+.....|
\-----------/ /--+--+--------\ # |....\-----/....| |.....|
|..............+#####++-----++-------/ \-+---/
|..../----\....| # ### ### ##
|....| |....| # # ++-+----------+-+-\
|....| |....| # ## /+........}}.......|\
\--+-\----/----/ ########+#...........#...#..|
# # #++------+---------/
> > I don't think the non-rectangular rooms are...
> > non-rectangular enough.
[...]
> > non-rectangular enough.
> > L and U shapes should be more common.
> Hmmm... what about embedded "pillars"
How about this sort of thing?
Layout Style: 3 (Non-Rectangular Rooms)
##
## /---------------\ /--\
### |...............+#####+-|..|-\
# ### |...............|\####+....}.|
/-----------+---+-\ |................|####|..._.&+############
/|.D..DD..D........+######+.........>......|# |..R...| #
|........D.........| \-...............|# |......+############
|...D.D.D..........+######+|...............+####+......| #
|.D.........D......| \--+------------/ \-|..|-+############
|..............D..-+########################### \--/ #
\-+-------+-------/ #/--------\ #
# # /---------------\ #|g../--\.| #
## /-+-----\ |...............| #|../|-\|.| #
# |.......| |../--\.........+#########+.&|| ||.| #
### /----\..| |..| |.........|/-+-+-\ |..|| ||.| #
# | |..| |..\--/...../--\||.....| |.<|| ||.+######## #
## | |..+####+._.........| |||./---+# |..|\--/.| ####
##\----/..| |...........\--/||.| |##+..\--/..+###########
+.......| ##+...............||.| | \--------/ #
|.......| ##\---+--------+--/|.\---/ #
\-------/ ##### # |.....| #
# # |...w.| #
# # \-----/ #
###########################################
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
/----------\ # /---------------------------\
|..........| # |...........................|
|..........|/-------+---------\|...........................|
|.../--\...||.................||...........................|
|...| |...||.................||...........................|
|...| |...||..../-++++++.....||...........................|
|...| |...+#....+##++##+.....||...................<.......|
|...| |...||....|# ||##|.....#+...........................|
\---\--/---/|....|# || #|.....||...........................|
|....\--/\--+.....||...........................|
|.................||...........................|
\-------------+---/\-----------------------+---/
## /---#----\
/-------------------+------------\ |........|
|................................| |........|
|................................| |........|
|......}.........................| |........|
|................................| |........|
|......................>.........| |........|
|................................| |........|
|................................| |........|
|................................| |........|
\--------------------------------/ |........|
layoutstyle 3
Using layout style 3.
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
# # # # /------------------------\
Placing corridors (style 4)...
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 4 (Hybrid)
#### # |.........q..............|
# ## /----\ |........................| #
# + |....| #|...........g............+### # #
# /--|....|--\#+#...................E...| ### #
# #|..........+#+..............w.........| ## # #
# \--|....|--/ \---+--------------------/ ######
# |....| +########################/---------+--+----\ ##
## # #++---/ # # ########+ #|.................|# +##
## ## ## # ## # # ##/-+|.................|--\#
# # ## # ## # ## |.......................|#
######### # ## \--|.................|--/#
## # ### ## # ## |.................|# #
+--------+-+---------+--\ # ## # \---------+-------/# #
|.....>......./--\......| # +-----\ + /--/---\--+
|./--\........| |......| /-----+---|.....|---------\|..| |..|
|.| |........\--/......| |....................<....||..| |.q|
|.\--/.................m| |.........................|+..| |..|
\++----------+----------/ |.........................+|..\---/F.|
# # ## # \---------|.....|---------/|..q......|
# # # # \-----/ # \----+---+/
# # # # # # #######
####################################################
# # #
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 3
Using layout style 3.
Placing corridors (style 3)...
Layout Style: 3 (Non-Rectangular Rooms)
/---------/--------\ /---\
|..................| |zw.|
# |..................| |...|
|j..........<......| |...|
\---------|........|/---|...| /------------------\
# |........||T...._@+ /|...............E..|
|........||.......+# +...&...............|
\-++---+-/|....E..+#####+...................|
# # ####+++++++-/## |..........h....g...|
# /------+++++++++------\ ## ## |... ......t...q...-/
|....d................| ## # \------++----------/
|.....................| ## ## ###
|.....................| ## ## ##
|.....................| ## # /++------\
\------|.......|+-----/ /---++++--+####+++......{.|
|.......|# |.........+ |..UO..g...|
# \-------/# #######+..o.|+---/ |..........|
/----------+++++++++\ |....| |..........|
# |}.................}| |....| |........--/
# |...>../-----\....E.| |...&| \--------/
|..}...| |.g..d.| |....|
|......| |To....| |....|
\------\-----/------/ \----/
nathan@warthog:~$ perl /b4/perl/nethack-dense-room-packer.pl
layoutstyle 3
Using layout style 3.
Placing corridors (style 1)...
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
! at /b4/perl/nethack-dense-room-packer.pl line 1271.
Layout Style: 3 (Non-Rectangular Rooms)
Corridor Style: 1 (Haphazard)
#
/--------------------------\ ##
|..........................| ####
|.........................&|+###### /--------\+ #
|...........................| # |......J.|----++###
|...........................| # |..............| #
\-........................x.| ## |..............| #
|..........................| /+------\ |>...&.........| #
\--------------------------/ |.......+#+&..........x..| #
/-----------------------\ |.......| |.HB.....|-----/ #
|.......................|+#/---------|.......| \--------/ #
|........................+#+.................|##### #
|........................| |.................+####################
\-..................<....| \---------\------+/ #
\-------------------+---/ # /-----\ #
/--\-#+----------------\ /-+--------\/-|.....| #
|g........L..}.........+###/------\nn.||.....}}| #
|ag|-------------------/ + |.n.++.......| #
#########+q.| /--------\ | |...||}}.}}..| #
# |.&| |.z..g..X|\ \------/..#||.....--/ #
# |.}+#########+.U.&..}fU| |..&&.#nnn.|\-----/ #
# |.&| |&E..P...H| \----------/ #
# \--/ \-.f..g...| #
#######################\--------/ #######
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
# # # # # # ## # # # ##
# # ## # # ##
# # #### # # #########
# # # ## /-----+--\ ###############
# ###########+++--+-------|........|--+--+--+---+####
## # ## # |..................................+####
# ## |..................................+####
# # |..................................| ###
+---\ ## |..................................+####
+...| ## |..................................+####
# +...| ### |....................>.............+####
/-+...|-\ ## |..................................+####
|.#.....| ## |..................................|###
########+.......+########+..................................+####
# |.......+ ##|..................................+####
|....<..|# #+..................................|####
# # |.......|## +-----+--++--+........+-+++-+++++-++####
|.......| ### # # # ## +-+----++/#################
# |.......|# ## # ### ######## #####################
|.......+###############################################
\-+...|-/ # # ## ## ##### ##### ####################
# +...| # ## ########################################
|...+##################################################
\---/ # ## # ## ##### ## # ## # ###### ######
Using layout style 3.
Placing corridors (style 2)...
Layout Style: 3 (Non-Rectangular Rooms)
/----------\ /---------\
#+..........| /------|.........|+-----\
|..........| |..................#d...|
|..........|----------------------\ |.E.....................|
|.......<.........................| +---++++.........|------/
\-+--+++++-/----------------------/##### \---------/
# # ## #/------------\
# # /--------\ /-+--+|............+++++++#######
# # /|........| |........................+
# # |.........+#####+.........O..............+
/--+------+-\ |.........| \-----|...U........|-----+
|..xLn......|\ \|........| ###############################
|........&...+###++-------/ # /----/-----\----\ ++++--\
|............| ### # |....| |....| |....F|
\-...........| # # # |....+#####+....+####+.....|
\-----------/ /--+--+--------\ # |....\-----/....| |.....|
|..............+#####++-----++-------/ \-+---/
|..../----\....| # ### ### ##
|....| |....| # # ++-+----------+-+-\
|....| |....| # ## /+........}}.......|\
\--+-\----/----/ ########+#...........#...#..|
# # #+........}.......}}.|
# # ++.........}>......|/
# # #++------+---------/
JG Miller
Dec 21, 2012, 7:36:08 PM12/21/12
to
Your code produces beautiful levels that would add a LOT of freshness
to the game, in my opinion. I like just looking at these levels.
Jim Miller
On Sat, 15 Dec 2012 14:36:37 -0800 (PST), Jonadab the Unsightly One
<jonadab.the...@gmail.com> wrote:
>Here's some more sample output. These all showcase the new hybrid
>corridor style.
...
to the game, in my opinion. I like just looking at these levels.
Jim Miller
On Sat, 15 Dec 2012 14:36:37 -0800 (PST), Jonadab the Unsightly One
<jonadab.the...@gmail.com> wrote:
>Here's some more sample output. These all showcase the new hybrid
>corridor style.
Martin Read
Jan 13, 2013, 9:52:00 AM1/13/13
to
Jonadab the Unsightly One <jonadab.the...@gmail.com> wrote:
>You underestimate how much easier Perl is
>to write than C. I'm just playing around with
>possible algorithms here. If I had to do this
>in C, I wouldn't be playing around with
>anywhere near as many different possible
>code paths, any one of which might end up
>just getting scrapped.
On the other hand, if you were working directly in C you could be
>to write than C. I'm just playing around with
>possible algorithms here. If I had to do this
>in C, I wouldn't be playing around with
>anywhere near as many different possible
>code paths, any one of which might end up
>just getting scrapped.
testing the way your new layouts interact with Nethack's game mechanics
as well as whether they were aesthetically satisfactory :)
--
\_\/_/ turbulence is certainty turbulence is friction between you and me
\ / every time we try to impose order we create chaos
\/ -- Killing Joke, "Mathematics of Chaos"
Topi Linkala
Jan 14, 2013, 4:07:53 AM1/14/13
to
18.12.2012 17:07, Jonadab the Unsightly One kirjoitti:
> Hmmm... what about rooms with embedded
> "pillars" (small sections of wall/rock
> within the room)?
If you can implement them so that the seiling falls down(1) if certain
> Hmmm... what about rooms with embedded
> "pillars" (small sections of wall/rock
> within the room)?
number of the columns are destroyed then I'm for it.
(1) Instadeath(tm).
Topi
--
"The whole problem with the world is that fools and fanatics are
always so certain of themselves, but wiser people so full of doubts."
- Bertrand Russell
"How come he didn't put 'I think' at the end of it?" - Anonymous
Jorgen Grahn
Jan 15, 2013, 6:37:21 AM1/15/13
to
On Mon, 2013-01-14, Topi Linkala wrote:
> 18.12.2012 17:07, Jonadab the Unsightly One kirjoitti:
>> Hmmm... what about rooms with embedded
>> "pillars" (small sections of wall/rock
>> within the room)?
>
> If you can implement them so that the seiling falls down(1) if certain
> number of the columns are destroyed then I'm for it.
>
> (1) Instadeath(tm).
Or an exotic way of killing a bunch of monsters at once ...
> 18.12.2012 17:07, Jonadab the Unsightly One kirjoitti:
>> Hmmm... what about rooms with embedded
>> "pillars" (small sections of wall/rock
>> within the room)?
>
> If you can implement them so that the seiling falls down(1) if certain
> number of the columns are destroyed then I'm for it.
>
> (1) Instadeath(tm).
/Jorgen
--
// Jorgen Grahn <grahn@ Oo o. . .
\X/ snipabacken.se> O o .
Janis Papanagnou
Jan 15, 2013, 1:19:13 PM1/15/13
to
On 15.01.2013 12:37, Jorgen Grahn wrote:
> On Mon, 2013-01-14, Topi Linkala wrote:
>> 18.12.2012 17:07, Jonadab the Unsightly One kirjoitti:
>>> Hmmm... what about rooms with embedded
>>> "pillars" (small sections of wall/rock
>>> within the room)?
>>
>> If you can implement them so that the seiling falls down(1) if certain
>> number of the columns are destroyed then I'm for it.
>>
>> (1) Instadeath(tm).
>
> Or an exotic way of killing a bunch of monsters at once ...
Related... A drum of earthquake should (in addition to the pits) create
> On Mon, 2013-01-14, Topi Linkala wrote:
>> 18.12.2012 17:07, Jonadab the Unsightly One kirjoitti:
>>> Hmmm... what about rooms with embedded
>>> "pillars" (small sections of wall/rock
>>> within the room)?
>>
>> If you can implement them so that the seiling falls down(1) if certain
>> number of the columns are destroyed then I'm for it.
>>
>> (1) Instadeath(tm).
>
> Or an exotic way of killing a bunch of monsters at once ...
falling rock traps and would loosen some rocks from the ceiling, and it
could destroy pillars as well.
Janis
0 new messages