File Coverage

blib/lib/Game/TextMapper/Gridmapper.pm
Criterion Covered Total %
statement 358 652 54.9
branch 103 272 37.8
condition 42 177 23.7
subroutine 38 52 73.0
pod 1 38 2.6
total 542 1191 45.5


line stmt bran cond sub pod time code
1             # Copyright (C) 2009-2021 Alex Schroeder
2             #
3             # This program is free software: you can redistribute it and/or modify it under
4             # the terms of the GNU Affero General Public License as published by the Free
5             # Software Foundation, either version 3 of the License, or (at your option) any
6             # later version.
7             #
8             # This program is distributed in the hope that it will be useful, but WITHOUT
9             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
10             # FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
11             # details.
12             #
13             # You should have received a copy of the GNU Affero General Public License along
14             # with this program. If not, see .
15              
16             =encoding utf8
17              
18             =head1 NAME
19              
20             Game::TextMapper::Gridmapper - generate dungeon maps
21              
22             =head1 DESCRIPTION
23              
24             This generates dungeon maps. At its core, this uses a 3×3 layout, 9 sections
25             total. 5 or 7 of these 9 sections get a room. The connections for the rooms (the
26             "shape") is picked at random from a fixed list of configurations (plus flipped
27             and rotated variants). The first room contains the stairs.
28              
29             To generate bigger dungeons, more of these 3×3 layouts are added to the first.
30             As the number of rooms is dynamic, the algorithm figures out how to best use a
31             number of layouts containing 5 or 7 rooms to get to that number, and then simply
32             drops the extra rooms.
33              
34             =head1 METHODS
35              
36             =cut
37              
38             package Game::TextMapper::Gridmapper;
39 1     1   8 use Game::TextMapper::Log;
  1         2  
  1         35  
40 1     1   5 use Game::TextMapper::Constants qw($dx $dy);
  1         2  
  1         135  
41 1     1   7 use Modern::Perl '2018';
  1         2  
  1         10  
42 1     1   219 use List::Util qw'shuffle none any min max all';
  1         2  
  1         99  
43 1     1   8 use List::MoreUtils qw'pairwise';
  1         2  
  1         13  
44 1     1   687 use Mojo::Util qw(url_escape);
  1         2  
  1         59  
45 1     1   6 use Mojo::Base -base;
  1         1  
  1         11  
46              
47             my $log = Game::TextMapper::Log->get;
48              
49             # This is the meta grid for the geomorphs. Normally this is (3,3) for simple
50             # dungeons. We need to recompute these when smashing geomorphs together.
51             has 'dungeon_dimensions';
52             has 'dungeon_geomorph_size';
53              
54             # This is the grid for a particular geomorph. This is space for actual tiles.
55             has 'room_dimensions';
56              
57             # Rows and columns, for the tiles. Add two tiles for the edges, so the first
58             # two rows and the last two rows, and the first two columns and the last two
59             # columns should be empty. This is the empty space where stairs can be added.
60             # (0,0) starts at the top left and goes rows before columns, like text. Max
61             # tiles is the maximum number of tiles. We need to recompute these values when
62             # smashing two geomorphs together.
63             has 'row';
64             has 'col';
65             has 'max_tiles';
66              
67             sub init {
68 1     1 0 3 my $self = shift;
69 1         6 $self->dungeon_geomorph_size(3); # this stays the same
70 1         16 $self->dungeon_dimensions([3, 3]); # this will change
71 1         10 $self->room_dimensions([5, 5]);
72 1         8 $self->recompute();
73             }
74              
75             sub recompute {
76 2     2 0 4 my $self = shift;
77 2         7 $self->row($self->dungeon_dimensions->[0]
78             * $self->room_dimensions->[0]
79             + 4);
80 2         22 $self->col($self->dungeon_dimensions->[1]
81             * $self->room_dimensions->[1]
82             + 4);
83 2         20 $self->max_tiles($self->row * $self->col - 1);
84             }
85              
86             =head2 generate_map($pillars, $n, $caves)
87              
88             If C<$pillars> is true, then rooms with pillars are generated. This is usually a
89             good idea. It's harder to pull off from I because the description
90             of the dungeon should mention the pillars but there's now way to do that.
91             Perhaps, if C<$pillars> were to be a reference of room numbers with pillars, it
92             might work; right now, however, it's simply a boolean value.
93              
94             C<$n> is number of rooms.
95              
96             If C<$caves> is true, then the entire map uses cave walls instead of regular
97             walls.
98              
99             =cut
100              
101             sub generate_map {
102 1     1 1 13 my $self = shift;
103 1         3 my $pillars = shift;
104 1         2 my $n = shift;
105 1         3 my $caves = shift;
106 1         6 $self->init;
107 1         14 my $rooms = [map { $self->generate_room($_, $pillars, $caves) } (1 .. $n)];
  5         11  
108 1         7 my ($shape, $stairs) = $self->shape(scalar(@$rooms));
109 1         5 my $tiles = $self->add_rooms($rooms, $shape);
110 1         5 $tiles = $self->add_corridors($tiles, $shape);
111 1 50       6 $tiles = $self->add_doors($tiles) unless $caves;
112 1 50       7 $tiles = $self->add_stair($tiles, $stairs) unless $caves;
113 1 50       5 $tiles = $self->add_small_stair($tiles, $stairs) if $caves;
114 1         5 $tiles = $self->fix_corners($tiles);
115 1 50       6 $tiles = $self->fix_pillars($tiles) if $pillars;
116 1 50       4 $tiles = $self->to_rocks($tiles) if $caves;
117 1         6 return $self->to_text($tiles);
118             }
119              
120             sub generate_room {
121 5     5 0 8 my $self = shift;
122 5         6 my $num = shift;
123 5         7 my $pillars = shift;
124 5         6 my $caves = shift;
125 5         9 my $r = rand();
126 5 50 0     13 if ($r < 0.9) {
    0 0        
127 5         10 return $self->generate_random_room($num);
128             } elsif ($r < 0.95 and $pillars or $caves) {
129 0         0 return $self->generate_pillar_room($num);
130             } else {
131 0         0 return $self->generate_fancy_corner_room($num);
132             }
133             }
134              
135             sub generate_random_room {
136 5     5 0 8 my $self = shift;
137 5         8 my $num = shift;
138             # generate the tiles necessary for a single geomorph
139 5         5 my @tiles;
140 5         12 my @dimensions = (2 + int(rand(3)), 2 + int(rand(3)));
141 5     10   15 my @start = pairwise { int(rand($b - $a)) } @dimensions, @{$self->room_dimensions};
  10         47  
  5         10  
142             # $log->debug("New room starting at (@start) for dimensions (@dimensions)");
143 5         16 for my $x ($start[0] .. $start[0] + $dimensions[0] - 1) {
144 17         52 for my $y ($start[1] .. $start[1] + $dimensions[1] - 1) {
145 50         160 $tiles[$x + $y * $self->room_dimensions->[0]] = ["empty"];
146             }
147             }
148 5         22 my $x = $start[0] + int($dimensions[0]/2);
149 5         8 my $y = $start[1] + int($dimensions[1]/2);
150 5         6 push(@{$tiles[$x + $y * $self->room_dimensions->[0]]}, "\"$num\"");
  5         11  
151 5         29 return \@tiles;
152             }
153              
154             sub generate_fancy_corner_room {
155 0     0 0 0 my $self = shift;
156 0         0 my $num = shift;
157 0         0 my @tiles;
158 0         0 my @dimensions = (3 + int(rand(2)), 3 + int(rand(2)));
159 0     0   0 my @start = pairwise { int(rand($b - $a)) } @dimensions, @{$self->room_dimensions};
  0         0  
  0         0  
160             # $log->debug("New room starting at (@start) for dimensions (@dimensions)");
161 0         0 for my $x ($start[0] .. $start[0] + $dimensions[0] - 1) {
162 0         0 for my $y ($start[1] .. $start[1] + $dimensions[1] - 1) {
163 0         0 push(@{$tiles[$x + $y * $self->room_dimensions->[0]]}, "empty");
  0         0  
164             # $log->debug("$x $y @{$tiles[$x + $y * $self->room_dimensions->[0]]}");
165             }
166             }
167 0 0       0 my $type = rand() < 0.5 ? "arc" : "diagonal";
168 0         0 $tiles[$start[0] + $start[1] * $self->room_dimensions->[0]] = ["$type-se"];
169 0         0 $tiles[$start[0] + $dimensions[0] + $start[1] * $self->room_dimensions->[0] -1] = ["$type-sw"];
170 0         0 $tiles[$start[0] + ($start[1] + $dimensions[1] - 1) * $self->room_dimensions->[0]] = ["$type-ne"];
171 0         0 $tiles[$start[0] + $dimensions[0] + ($start[1] + $dimensions[1] - 1) * $self->room_dimensions->[0] - 1] = ["$type-nw"];
172 0         0 my $x = $start[0] + int($dimensions[0]/2);
173 0         0 my $y = $start[1] + int($dimensions[1]/2);
174 0         0 push(@{$tiles[$x + $y * $self->room_dimensions->[0]]}, "\"$num\"");
  0         0  
175 0         0 return \@tiles;
176             }
177              
178             sub generate_pillar_room {
179 0     0 0 0 my $self = shift;
180 0         0 my $num = shift;
181 0         0 my @tiles;
182 0         0 my @dimensions = (3 + int(rand(2)), 3 + int(rand(2)));
183 0     0   0 my @start = pairwise { int(rand($b - $a)) } @dimensions, @{$self->room_dimensions};
  0         0  
  0         0  
184             # $log->debug("New room starting at (@start) for dimensions (@dimensions)");
185 0         0 my $type = "|";
186 0         0 for my $x ($start[0] .. $start[0] + $dimensions[0] - 1) {
187 0         0 for my $y ($start[1] .. $start[1] + $dimensions[1] - 1) {
188 0 0 0     0 if ($type eq "|" and ($x == $start[0] or $x == $start[0] + $dimensions[0] - 1)
      0        
      0        
      0        
      0        
189             or $type eq "-" and ($y == $start[1] or $y == $start[1] + $dimensions[1] - 1)) {
190 0         0 push(@{$tiles[$x + $y * $self->room_dimensions->[0]]}, "pillar");
  0         0  
191             } else {
192 0         0 push(@{$tiles[$x + $y * $self->room_dimensions->[0]]}, "empty");
  0         0  
193             # $log->debug("$x $y @{$tiles[$x + $y * $self->room_dimensions->[0]]}");
194             }
195             }
196             }
197 0         0 my $x = $start[0] + int($dimensions[0]/2);
198 0         0 my $y = $start[1] + int($dimensions[1]/2);
199 0         0 push(@{$tiles[$x + $y * $self->room_dimensions->[0]]}, "\"$num\"");
  0         0  
200 0         0 return \@tiles;
201             }
202              
203             sub one {
204 6     6 0 19 return $_[int(rand(scalar @_))];
205             }
206              
207             =head1 LAYOUT
208              
209             One of the shapes is picked, and then flipped and rotated to generate more
210             shapes. This is why we can skip any shape that is a flipped and/or rotated
211             version of an existing shape.
212              
213             =head2 5 Room Dungeons
214              
215             These are inspired by L
216             Dungeon|https://gnomestew.com/the-nine-forms-of-the-five-room-dungeon/> by
217             Matthew J. Neagley, for Gnome Stew.
218              
219             =cut
220              
221             sub five_room_shape {
222 1     1 0 2 my $self = shift;
223 1         3 my $n = shift;
224 1         3 my @shapes;
225              
226             =head3 The Railroad
227              
228             5 5 4--5 5--4
229             | | | |
230             4 3--4 3 5--4 3
231             | | | | |
232             1--2--3 1--2 1--2 1--2--3 1--2
233              
234             =cut
235              
236 1         20 push(@shapes,
237             [[0, 2], [1, 2], [2, 2], [2, 1], [2, 0]],
238             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 0]],
239             [[0, 2], [1, 2], [1, 1], [1, 0], [2, 0]],
240             [[0, 2], [1, 2], [2, 2], [2, 1], [1, 1]],
241             [[0, 2], [1, 2], [1, 1], [1, 0], [0, 0]]);
242              
243             =head3 Foglio's Snail
244              
245             5 4
246             | |
247             1--2--3
248              
249             =cut
250              
251             # Note how whenever there is a non-linear connection, there is a an extra
252             # element pointing to the "parent". This is necessary for all but the
253             # railroads.
254 1         6 push(@shapes,
255             [[0, 2], [1, 2], [2, 2], [2, 1], [1, 1, 1]]);
256              
257             =head3 The Fauchard Fork
258              
259             5 5
260             | |
261             3--4 4--3 5--3--4
262             | | |
263             1--2 1--2 1--2
264              
265             =cut
266              
267 1         9 push(@shapes,
268             [[0, 2], [1, 2], [1, 1], [2, 1], [1, 0, 2]],
269             [[0, 2], [1, 2], [1, 1], [0, 1], [1, 0, 2]],
270             [[0, 2], [1, 2], [1, 1], [2, 1], [0, 1, 2]]);
271              
272             =head3 The Moose
273              
274             4
275             |
276             5 4 5 3
277             | | | |
278             1--2--3 1--2
279              
280             =cut
281              
282 1         10 push(@shapes,
283             [[0, 2], [1, 2], [2, 2], [2, 1], [0, 1, 0]],
284             [[0, 2], [1, 2], [1, 1], [1, 0], [0, 1, 0]]);
285              
286             =head3 The Paw
287              
288             5
289             |
290             3--2--4
291             |
292             1
293              
294             =cut
295              
296 1         7 push(@shapes,
297             [[1, 2], [1, 1], [0, 1], [2, 1, 1], [1, 0, 1]]);
298              
299             =head3 The Arrow
300              
301             3
302             |
303             2
304             |
305             5--1--4
306              
307             =cut
308              
309 1         6 push(@shapes,
310             [[1, 2], [1, 1], [1, 0], [2, 2, 0], [0, 2, 0]]);
311              
312             =head3 The Cross
313              
314             5
315             |
316             3--1--4
317             |
318             2
319              
320             =cut
321              
322 1         7 push(@shapes,
323             [[1, 1], [1, 2], [0, 1, 0], [2, 1, 0], [1, 0, 0]]);
324              
325             =head3 The Nose Ring
326              
327             5--4 2--3--4
328             | | | |
329             1--2--3 1--5
330              
331             =cut
332              
333 1         10 push(@shapes,
334             [[0, 2], [1, 2], [2, 2], [2, 1], [1, 1, 1, 3]],
335             [[0, 2], [0, 1], [1, 1], [2, 1], [1, 2, 0, 2]]);
336              
337 1         6 return $self->shape_trim($self->shape_flip(one(@shapes)), $n);
338             }
339              
340             =head2 7 Room Dungeons
341              
342             High room density is a desirable property, so we can fill the 9 sections of the
343             3×3 base layout with more than just five rooms. The algorithm uses 7 room
344             shapes in addition to the five room shapes.
345              
346             =cut
347              
348             sub seven_room_shape {
349 0     0 0 0 my $self = shift;
350 0         0 my $n = shift;
351 0         0 my @shapes;
352              
353             =head3 The Snake
354              
355             7--6--5 7--6--5 4--5 7
356             | | | | |
357             4 3--4 3 6 6--5--4
358             | | | | |
359             1--2--3 1--2 1--2 7 1--2--3
360              
361             =cut
362              
363 0         0 push(@shapes,
364             [[0, 2], [1, 2], [2, 2], [2, 1], [2, 0], [1, 0], [0, 0]],
365             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 0], [1, 0], [0, 0]],
366             [[0, 2], [1, 2], [1, 1], [1, 0], [2, 0], [2, 1], [2, 2]],
367             [[0, 2], [1, 2], [2, 2], [2, 1], [1, 1] ,[0, 1], [0, 0]]);
368              
369             =head3 The Fork
370              
371             7 5 7 5 7-----5
372             | | | | | |
373             6 4 6 4 6 4
374             | | | | | |
375             1--2--3 1--2--3 1--2--3
376              
377             =cut
378              
379             # Note how whenever there is a non-linear connection, there is a an extra
380             # element pointing to the "parent". This is necessary for all but the
381             # railroads.
382              
383 0         0 push(@shapes,
384             [[0, 2], [1, 2], [2, 2], [2, 1], [2, 0], [1, 1, 1], [1, 0]],
385             [[0, 2], [1, 2], [2, 2], [2, 1], [2, 0], [0, 1, 0], [0, 0]],
386             [[0, 2], [1, 2], [2, 2], [2, 1], [2, 0], [0, 1, 0], [0, 0, 5, 4]]);
387              
388             =head3 The Sidequest
389              
390             6--5 5--6 7 5 6--5 5--6 7 5
391             | | | | | | | | | | | |
392             7 3--4 4--3 7 6--3--4 7 3--4 4--3 7 6--3--4
393             | | | | | | | | |
394             1--2 1--2 1--2 1--2 1--2 1--2
395              
396             =cut
397              
398 0         0 push(@shapes,
399             [[0, 2], [1, 2], [1, 1], [2, 1], [1, 0, 2], [0, 0], [0, 1]],
400             [[0, 2], [1, 2], [1, 1], [0, 1], [1, 0, 2], [2, 0], [2, 1]],
401             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 0], [0, 1, 2], [0, 0]],
402             [[0, 2], [1, 2], [1, 1], [2, 1], [1, 0, 2], [0, 0], [0, 1, 5, 0]],
403             [[0, 2], [1, 2], [1, 1], [0, 1, 2, 0], [1, 0, 2], [2, 0], [2, 1]],
404             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 0], [0, 1, 2, 0], [0, 0]]);
405              
406             =head3 The Unbalanced Fork
407              
408             7 5 7 4--5 7 5 7 7 4--5 7 5 7
409             | | | | | | | | | | | |
410             6 4 6 3 6 3--4 6 3--4 6--3 6--3--4 6--3--4
411             | | | | | | | | | | | | | | | |
412             1--2--3 1--2 1--2 1--2 5 1--2 1--2 1--2 5
413              
414             =cut
415              
416 0         0 push(@shapes,
417             [[0, 2], [1, 2], [2, 2], [2, 1], [2, 0], [0, 1, 0], [0, 0]],
418             [[0, 2], [1, 2], [1, 1], [1, 0], [2, 0], [0, 1, 0], [0, 0]],
419             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 0], [0, 1, 0], [0, 0]],
420             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 2], [0, 1, 0], [0, 0]],
421             [[0, 2], [1, 2], [1, 1], [1, 0], [2, 0], [0, 1, 2, 0], [0, 0]],
422             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 0], [0, 1, 2, 0], [0, 0]],
423             [[0, 2], [1, 2], [1, 1], [2, 1], [2, 2], [0, 1, 2, 0], [0, 0]]);
424              
425             =head3 The Triplet
426              
427             4 5 7 5 7 5 4--5 7 5 7 5
428             | | | | | | | | | | | |
429             3--2--6 3--2--6 3--2--6 3--2--6 3--2--6 3--2--6
430             | | | | | | | | | | | |
431             1 4 1 4 1 7 1 4--1 4--1 7
432              
433             =cut
434              
435 0         0 push(@shapes,
436             [[1, 2], [1, 1], [0, 1], [0, 0], [1, 0, 1], [2, 1, 1], [2, 0]],
437             [[1, 2], [1, 1], [0, 1], [0, 2], [1, 0, 1], [2, 1, 1], [2, 0]],
438             [[1, 2], [1, 1], [0, 1], [0, 2], [1, 0, 1], [2, 1, 1], [2, 2]],
439             [[1, 2], [1, 1], [0, 1], [0, 0], [1, 0, 1, 3], [2, 1, 1], [2, 0]],
440             [[1, 2], [1, 1], [0, 1], [0, 2, 2, 0], [1, 0, 1], [2, 1, 1], [2, 0]],
441             [[1, 2], [1, 1], [0, 1], [0, 2, 2, 0], [1, 0, 1], [2, 1, 1], [2, 2]]);
442              
443             =head3 The Fake Fork
444              
445             7 3 7 7 3 7
446             | | | | | |
447             6 2 6 2--3 6--2 6--2--3
448             | | | | | | | |
449             5--1--4 5--1--4 5--1--4 5--1--4
450              
451             =cut
452              
453 0         0 push(@shapes,
454             [[1, 2], [1, 1], [1, 0], [2, 2, 0], [0, 2, 0], [0, 1], [0, 0]],
455             [[1, 2], [1, 1], [2, 1], [2, 2, 0], [0, 2, 0], [0, 1], [0, 0]],
456             [[1, 2], [1, 1], [1, 0], [2, 2, 0], [0, 2, 0], [0, 1, 4, 1], [0, 0]],
457             [[1, 2], [1, 1], [2, 1], [2, 2, 0], [0, 2, 0], [0, 1, 4, 1], [0, 0]]);
458              
459             =head3 The Shuriken
460              
461             5 6--7 5 6--7 5--6 5--6--7 5--6--7 5--6
462             | | | | | | | | | |
463             4--1 4--1 4--1--7 4--1 4--1 4--1--7
464             | | | | | | |
465             3--2 2--3 3--2 3--2 2--3 3--2
466              
467             =cut
468              
469 0         0 push(@shapes,
470             [[1, 1], [1, 2], [0, 2], [0, 1, 0], [0, 0], [1, 0, 0], [2, 0]],
471             [[1, 1], [1, 2], [2, 2], [0, 1, 0], [0, 0], [1, 0, 0], [2, 0]],
472             [[1, 1], [1, 2], [0, 2], [0, 1, 0], [0, 0], [1, 0], [2, 1, 0]],
473             [[1, 1], [1, 2], [0, 2], [0, 1, 0], [0, 0], [1, 0, 4, 0], [2, 0]],
474             [[1, 1], [1, 2], [2, 2], [0, 1, 0], [0, 0], [1, 0, 4, 0], [2, 0]],
475             [[1, 1], [1, 2], [0, 2], [0, 1, 2, 0], [0, 0], [1, 0], [2, 1, 0]]);
476              
477             =head3 The Noose
478              
479             6--5 3--4 3--4
480             | | | | | |
481             7 4 2 5 2 5--7
482             | | | | | |
483             1--2--3 1--6--7 1--6
484              
485             =cut
486              
487 0         0 push(@shapes,
488             [[0, 2], [1, 2], [2, 2], [2, 1], [2, 0], [1, 0], [1, 1, 1, 5]],
489             [[0, 2], [0, 1], [0, 0], [1, 0], [1, 1], [1, 2, 0, 4], [2, 2, 5]],
490             [[0, 2], [0, 1], [0, 0], [1, 0], [1, 1], [1, 2, 0, 4], [2, 1, 4]]);
491              
492 0         0 return $self->shape_trim($self->shape_flip(one(@shapes)), $n);
493             }
494              
495             sub shape_flip {
496 1     1 0 2 my $self = shift;
497 1         2 my $shape = shift;
498 1         3 my $r = rand;
499             # in case we are debugging
500             # $r = 1;
501 1 50       5 if ($r < 0.20) {
    0          
    0          
    0          
502             # flip vertically
503 1         3 $shape = [map{ $_->[1] = $self->dungeon_dimensions->[1] - 1 - $_->[1]; $_ } @$shape];
  5         10  
  5         19  
504             # $log->debug("flip vertically: " . join(", ", map { "[@$_]"} @$shape));
505             } elsif ($r < 0.4) {
506             # flip horizontally
507 0         0 $shape = [map{ $_->[0] = $self->dungeon_dimensions->[0] - 1 - $_->[0]; $_ } @$shape];
  0         0  
  0         0  
508             # $log->debug("flip horizontally: " . join(", ", map { "[@$_]"} @$shape));
509             } elsif ($r < 0.6) {
510             # flip diagonally
511 0         0 $shape = [map{ my $t = $_->[1]; $_->[1] = $_->[0]; $_->[0] = $t; $_ } @$shape];
  0         0  
  0         0  
  0         0  
  0         0  
512             # $log->debug("flip diagonally: " . join(", ", map { "[@$_]"} @$shape));
513             } elsif ($r < 0.8) {
514             # flip diagonally
515 0         0 $shape = [map{ $_->[0] = $self->dungeon_dimensions->[0] - 1 - $_->[0];
  0         0  
516 0         0 $_->[1] = $self->dungeon_dimensions->[1] - 1 - $_->[1];
517 0         0 $_ } @$shape];
518             # $log->debug("flip both: " . join(", ", map { "[@$_]"} @$shape));
519             }
520 1         5 return $shape;
521             }
522              
523             sub shape_trim {
524 1     1 0 3 my $self = shift;
525 1         2 my $shape = shift;
526 1         4 my $n = shift;
527 1         3 splice(@$shape, $n);
528 1         13 return $shape;
529             }
530              
531             sub shape_merge {
532 1     1 0 3 my $self = shift;
533 1         4 my @shapes = @_;
534 1         2 my $result = [];
535 1         7 my $cols = POSIX::ceil(sqrt(@shapes));
536 1         3 my $shift = [0, 0];
537 1         2 my $rooms = 0;
538 1         3 for my $shape (@shapes) {
539             # $log->debug(join(" ", "Shape", map { "[@$_]" } @$shape));
540 1         3 my $n = @$shape;
541             # $log->debug("Number of rooms for this shape is $n");
542             # $log->debug("Increasing coordinates by ($shift->[0], $shift->[1])");
543 1         3 for my $room (@$shape) {
544 5         11 $room->[0] += $shift->[0] * $self->dungeon_geomorph_size;
545 5         18 $room->[1] += $shift->[1] * $self->dungeon_geomorph_size;
546 5         17 for my $i (2 .. $#$room) {
547             # $log->debug("Increasing room reference $i ($room->[$i]) by $rooms");
548 1         3 $room->[$i] += $rooms;
549             }
550 5         10 push(@$result, $room);
551             }
552 1 50       5 $self->shape_reconnect($result, $n) if $n < @$result;
553 1 50       4 if ($shift->[0] == $cols -1) {
554 1         4 $shift = [0, $shift->[1] + 1];
555             } else {
556 0         0 $shift = [$shift->[0] + 1, $shift->[1]];
557             }
558 1         2 $rooms += $n;
559             }
560             # Update globals
561 1         5 for my $dim (0, 1) {
562 2         7 $self->dungeon_dimensions->[$dim] = max(map { $_->[$dim] } @$result) + 1;
  10         21  
563             }
564             # $log->debug("Dimensions of the dungeon are (" . join(", ", map { $self->dungeon_dimensions->[$_] } 0, 1) . ")");
565 1         12 $self->recompute();
566 1         9 return $result;
567             }
568              
569             sub shape_reconnect {
570 0     0 0 0 my ($self, $result, $n) = @_;
571 0         0 my $rooms = @$result;
572 0         0 my $first = $rooms - $n;
573             # Disconnect the old room by adding an invalid self-reference to the first
574             # room of the last shape added; if there are just two numbers there, it would
575             # otherwise mean that the first room of the new shape connects to the last
576             # room of the previous shape and that is wrong.
577             # $log->debug("First of the shape is @{$result->[$first]}");
578 0 0       0 push(@{$result->[$first]}, $first) if @{$result->[$first]} == 2;
  0         0  
  0         0  
579             # New connections can be either up or left, therefore only the rooms within
580             # this shape that are at the left or the upper edge need to be considered.
581 0         0 my @up_candidates;
582             my @left_candidates;
583 0         0 my $min_up;
584 0         0 my $min_left;
585 0         0 for my $start ($first .. $rooms - 1) {
586 0         0 my $x = $result->[$start]->[0];
587 0         0 my $y = $result->[$start]->[1];
588             # Check up: if we find a room in our set, this room is disqualified; if we
589             # find another room, record the distance, and the destination.
590 0         0 for my $end (0 .. $first - 1) {
591 0 0       0 next if $start == $end;
592 0 0       0 next if $result->[$end]->[0] != $x;
593 0         0 my $d = $y - $result->[$end]->[1];
594 0 0 0     0 next if $min_up and $d > $min_up;
595 0 0 0     0 if (not $min_up or $d < $min_up) {
596             # $log->debug("$d for $start → $end is smaller than $min_up: ") if defined $min_up;
597 0         0 $min_up = $d;
598 0         0 @up_candidates = ([$start, $end]);
599             } else {
600             # $log->debug("$d for $start → $end is the same as $min_up");
601 0         0 push(@up_candidates, [$start, $end]);
602             }
603             }
604             # Check left: if we find a room in our set, this room is disqualified; if we
605             # find another room, record the distance, and the destination.
606 0         0 for my $end (0 .. $first - 1) {
607 0 0       0 next if $start == $end;
608 0 0       0 next if $result->[$end]->[1] != $y;
609 0         0 my $d = $x - $result->[$end]->[0];
610 0 0 0     0 next if $min_left and $d > $min_left;
611 0 0 0     0 if (not $min_left or $d < $min_left) {
612 0         0 $min_left = $d;
613 0         0 @left_candidates = ([$start, $end]);
614             } else {
615 0         0 push(@left_candidates, [$start, $end]);
616             }
617             }
618             }
619             # $log->debug("up candidates: " . join(", ", map { join(" → ", map { $_ < 10 ? $_ : chr(55 + $_) } @$_) } @up_candidates));
620             # $log->debug("left candidates: " . join(", ", map { join(" → ", map { $_ < 10 ? $_ : chr(55 + $_) } @$_) } @left_candidates));
621 0         0 for (one(@up_candidates), one(@left_candidates)) {
622 0 0       0 next unless $_;
623 0         0 $log->debug("Connecting " . join(" → ", map { sprintf("%2x", $_) } @$_));
  0         0  
624 0         0 my ($start, $end) = @$_;
625 0 0 0     0 if (@{$result->[$start]} == 3 and $result->[$start]->[2] == $start) {
  0         0  
626             # remove the fake connection if there is one
627 0         0 pop(@{$result->[$start]});
  0         0  
628             } else {
629             # connecting to the previous room (otherwise the new connection replaces
630             # the implicit connection to the previous room)
631 0         0 push(@{$result->[$start]}, $start - 1);
  0         0  
632             }
633             # connect to the new one
634 0         0 push(@{$result->[$start]}, $end);
  0         0  
635             }
636             }
637              
638             sub debug_shapes {
639 0     0 0 0 my $self = shift;
640 0         0 my $shapes = shift;
641 0         0 my $map = [map { [ map { " " } 0 .. $self->dungeon_dimensions->[0] - 1] } 0 .. $self->dungeon_dimensions->[1] - 1];
  0         0  
  0         0  
642 0         0 $log->debug(join(" ", " ", map { sprintf("%2x", $_) } 0 .. $self->dungeon_dimensions->[0] - 1));
  0         0  
643 0         0 for my $n (0 .. $#$shapes) {
644 0         0 my $shape = $shapes->[$n];
645 0         0 $map->[ $shape->[1] ]->[ $shape->[0] ] = sprintf("%2x", $n);
646             }
647 0         0 for my $y (0 .. $self->dungeon_dimensions->[1] - 1) {
648 0         0 $log->debug(join(" ", sprintf("%2x", $y), @{$map->[$y]}));
  0         0  
649             }
650             }
651              
652             sub shape {
653 1     1 0 3 my $self = shift;
654             # note which rooms get stairs (identified by label!)
655 1         3 my $stairs;
656             # return an array of deltas to shift rooms around
657 1         2 my $num = shift;
658 1         2 my $shape = [];
659             # attempt to factor into 5 and 7 rooms
660 1         3 my $sevens = int($num/7);
661 1         5 my $rest = $num - 7 * $sevens; # $num % 7
662 1   33     7 while ($sevens > 0 and $rest % 5) {
663 0         0 $sevens--;
664 0         0 $rest = $num - 7 * $sevens;
665             }
666 1         8 my $fives = POSIX::floor($rest/5);
667 1         7 my @sequence = shuffle((5) x $fives, (7) x $sevens);
668 1         4 $rest = $num - 7 * $sevens - 5 * $fives;
669 1 50       4 push(@sequence, $rest) if $rest;
670 1         11 $log->debug("Sequence for $num rooms: " . join(" ", @sequence));
671 1 50       12 $shape = $self->shape_merge(map { $_ == 7 ? $self->seven_room_shape($_) : $self->five_room_shape($_) } @sequence);
  1         7  
672 1         5 for (my $n = 0; @sequence; $n += shift(@sequence)) {
673 1         5 push(@$stairs, $n + 1);
674             }
675 1         6 $log->debug(join(" ", "Stairs", @$stairs));
676 1 50       9 if (@$stairs > 2) {
677 0         0 @$stairs = shuffle(@$stairs);
678 0         0 my $n = POSIX::floor(log($#$stairs));
679 0         0 @$stairs = @$stairs[0 .. $n];
680             }
681 1 50       5 $self->debug_shapes($shape) if $log->level eq 'debug';
682 1         6 $log->debug(join(", ", map { "[@$_]"} @$shape));
  5         19  
683 1 50       9 die("No appropriate dungeon shape found for $num rooms") unless @$shape;
684 1         5 return $shape, $stairs;
685             }
686              
687             sub debug_tiles {
688 0     0 0 0 my $self = shift;
689 0         0 my $tiles = shift;
690 0         0 my $i = 0;
691             $log->debug(
692             join('', " " x 5,
693             map {
694 0         0 sprintf("% " . $self->room_dimensions->[0] . "d", $_ * $self->room_dimensions->[0])
  0         0  
695             } 1 .. $self->dungeon_dimensions->[0]));
696 0         0 while ($i < @$tiles) {
697             $log->debug(
698             sprintf("%4d ", $i)
699 0 0       0 . join('', map { $_ ? "X" : " " } @$tiles[$i .. $i + $self->row - 1]));
  0         0  
700 0         0 $i += $self->row;
701             }
702             }
703              
704             sub add_rooms {
705 1     1 0 3 my $self = shift;
706             # Get the rooms and the deltas, draw it all on a big grid. Don't forget the
707             # two-tile border around it all.
708 1         3 my $rooms = shift;
709 1         2 my $deltas = shift;
710 1         2 my @tiles;
711             pairwise {
712 5     5   32 my $room = $a;
713 5         8 my $delta = $b;
714             # $log->debug("Draw room shifted by delta (@$delta)");
715             # copy the room, shifted appropriately
716 5         10 for my $x (0 .. $self->room_dimensions->[0] - 1) {
717 25         163 for my $y (0 .. $self->room_dimensions->[0] - 1) {
718             # my $v =
719 125         791 $tiles[$x + $delta->[0] * $self->room_dimensions->[0] + 2
720             + ($y + $delta->[1] * $self->room_dimensions->[1] + 2)
721             * $self->row]
722             = $room->[$x + $y * $self->room_dimensions->[0]];
723             }
724             }
725 1         10 } @$rooms, @$deltas;
726             # $self->debug_tiles(\@tiles) if $log->level eq 'debug';
727 1         15 return \@tiles;
728             }
729              
730             sub add_corridors {
731 1     1 0 2 my $self = shift;
732 1         4 my $tiles = shift;
733 1         3 my $shapes = shift; # reference to the original
734 1         4 my @shapes = @$shapes; # a copy that gets shorter
735 1         2 my $from = shift(@shapes);
736 1         3 my $delta;
737 1         3 for my $to (@shapes) {
738 4 50 66     23 if (@$to == 3
    100 66        
739             and $to->[0] == $shapes->[$to->[2]]->[0]
740             and $to->[1] == $shapes->[$to->[2]]->[1]) {
741             # If the preceding shape is pointing to ourselves, then this room is
742             # disconnected: don't add a corridor.
743             # $log->debug("No corridor from @$from to @$to");
744 0         0 $from = $to;
745             } elsif (@$to == 2) {
746             # The default case is that the preceding shape is our parent. A simple
747             # railroad!
748             # $log->debug("Regular from @$from to @$to");
749 3         8 $tiles = $self->add_corridor($tiles, $from, $to, $self->get_delta($from, $to));
750 3         5 $from = $to;
751             } else {
752             # In case the shapes are not connected in order, the parent shapes are
753             # available as extra elements.
754 1         5 for my $from (map { $shapes->[$_] } @$to[2 .. $#$to]) {
  1         4  
755             # $log->debug("Branch from @$from to @$to");
756 1         5 $tiles = $self->add_corridor($tiles, $from, $to, $self->get_delta($from, $to));
757             }
758 1         3 $from = $to;
759             }
760             }
761 1 50       4 $self->debug_tiles($tiles) if $log->level eq 'debug';
762 1         8 return $tiles;
763             }
764              
765             sub get_delta {
766 4     4 0 6 my $self = shift;
767 4         5 my $from = shift;
768 4         5 my $to = shift;
769             # Direction: north is minus an entire row, south is plus an entire row, east
770             # is plus one, west is minus one. Return an array reference with three
771             # elements: how to get the next element and how to get the two elements to the
772             # left and right.
773 4 100       18 if ($to->[0] < $from->[0]) {
    100          
    50          
    50          
774             # $log->debug("west");
775 1         7 return [-1, - $self->row, $self->row];
776             } elsif ($to->[0] > $from->[0]) {
777             # $log->debug("east");
778 1         4 return [1, - $self->row, $self->row];
779             } elsif ($to->[1] < $from->[1]) {
780             # $log->debug("north");
781 0         0 return [- $self->row, 1, -1];
782             } elsif ($to->[1] > $from->[1]) {
783             # $log->debug("south");
784 2         6 return [$self->row, 1, -1];
785             } else {
786 0         0 $log->warn("unclear direction: bogus shape?");
787             }
788             }
789              
790             sub position_in {
791 8     8 0 12 my $self = shift;
792             # Return a position in the big array corresponding to the midpoint in a room.
793             # Don't forget the two-tile border.
794 8         9 my $delta = shift;
795 8         14 my $x = int($self->room_dimensions->[0]/2) + 2;
796 8         31 my $y = int($self->room_dimensions->[1]/2) + 2;
797 8         30 return $x + $delta->[0] * $self->room_dimensions->[0]
798             + ($y + $delta->[1] * $self->room_dimensions->[1]) * $self->row;
799             }
800              
801             sub add_corridor {
802 4     4 0 22 my $self = shift;
803             # In the example below, we're going east from F to T. In order to make sure
804             # that we also connect rooms in (0,0)-(1,1), we start one step earlier (1,2)
805             # and end one step later (8,2).
806             #
807             # 0123456789
808             # 0
809             # 1
810             # 2 F T
811             # 3
812             # 4
813 4         6 my $tiles = shift;
814 4         5 my $from = shift;
815 4         4 my $to = shift;
816             # $log->debug("Drawing a corridor [@$from]-[@$to]");
817             # Delta has three elements: forward, left and right indexes.
818 4         6 my $delta = shift;
819             # Convert $from and $to to indexes into the tiles array.
820 4         10 $from = $self->position_in($from) - 2 * $delta->[0];
821 4         28 $to = $self->position_in($to) + 2 * $delta->[0];
822 4         25 my $n = 0;
823 4         6 my $contact = 0;
824 4         6 my $started = 0;
825 4         5 my @undo;
826             # $log->debug("Drawing a corridor $from-$to");
827 4         8 while (not grep { $to == ($from + $_) } @$delta) {
  108         175  
828 32         67 $from += $delta->[0];
829             # contact is if we're on a room, or to the left or right of a room (but not in front of a room)
830 32     52   93 $contact = any { $self->something($tiles, $from, $_) } 0, $delta->[1], $delta->[2];
  52         85  
831 32 100       66 if ($contact) {
832 22         24 $started = 1;
833 22         34 @undo = ();
834             } else {
835 10         15 push(@undo, $from);
836             }
837 32 100 100     86 $tiles->[$from] = ["empty"] if $started and not $tiles->[$from];
838 32 50       62 last if $n++ > 20; # safety!
839             }
840 4         8 for (@undo) {
841 0         0 $tiles->[$_] = undef;
842             }
843 4         8 return $tiles;
844             }
845              
846             sub add_doors {
847 1     1 0 2 my $self = shift;
848 1         2 my $tiles = shift;
849             # Doors can be any tile that has three or four neighbours, including
850             # diagonally:
851             #
852             # ▓▓ ▓▓
853             # ▓▓▒▓ ▓▓▒▓
854             # ▓▓
855 1         5 my @types = qw(door door door door door door secret secret archway concealed);
856             # first two neighbours must be clear, the next two must be set, and one of the others must be set as well
857 1         5 my %test = (n => [-1, 1, -$self->row, $self->row, -$self->row + 1, -$self->row - 1],
858             e => [-$self->row, $self->row, -1, 1, $self->row + 1, -$self->row + 1],
859             s => [-1, 1, -$self->row, $self->row, $self->row + 1, $self->row - 1],
860             w => [-$self->row, $self->row, -1, 1, $self->row - 1, -$self->row - 1]);
861 1         37 my @doors;
862 1         13 for my $here (shuffle 1 .. scalar(@$tiles) - 1) {
863 235         365 for my $dir (shuffle qw(n e s w)) {
864 940 100 100     1588 if ($tiles->[$here]
      100        
      66        
      66        
      100        
      66        
      100        
865             and not $self->something($tiles, $here, $test{$dir}->[0])
866             and not $self->something($tiles, $here, $test{$dir}->[1])
867             and $self->something($tiles, $here, $test{$dir}->[2])
868             and $self->something($tiles, $here, $test{$dir}->[3])
869             and ($self->something($tiles, $here, $test{$dir}->[4])
870             or $self->something($tiles, $here, $test{$dir}->[5]))
871             and not $self->doors_nearby($here, \@doors)) {
872 5 50       11 $log->warn("$here content isn't 'empty'") unless $tiles->[$here]->[0] eq "empty";
873 5         12 my $type = one(@types);
874 5         6 my $variant = $dir;
875 5         7 my $target = $here;
876             # this makes sure doors are on top
877 5 100       17 if ($dir eq "s") { $target += $self->row; $variant = "n"; }
  1 100       4  
  1         4  
878 1         4 elsif ($dir eq "e") { $target += 1; $variant = "w"; }
  1         3  
879 5         7 push(@{$tiles->[$target]}, "$type-$variant");
  5         14  
880 5         11 push(@doors, $here);
881             }
882             }
883             }
884 1         13 return $tiles;
885             }
886              
887             sub doors_nearby {
888 8     8 0 13 my $self = shift;
889 8         11 my $here = shift;
890 8         9 my $doors = shift;
891 8         14 for my $door (@$doors) {
892 19 100       31 return 1 if $self->distance($door, $here) < 2;
893             }
894 5         14 return 0;
895             }
896              
897             sub distance {
898 201     201 0 228 my $self = shift;
899 201         215 my $from = shift;
900 201         213 my $to = shift;
901 201         275 my $dx = $to % $self->row - $from % $self->row;
902 201         814 my $dy = int($to/$self->row) - int($from/$self->row);
903 201         988 return sqrt($dx * $dx + $dy * $dy);
904             }
905              
906             sub add_stair {
907 1     1 0 3 my $self = shift;
908 1         3 my $tiles = shift;
909 1         1 my $stairs = shift;
910             STAIR:
911 1         4 for my $room (@$stairs) {
912             # find the middle using the label
913 1         2 my $start;
914 1         5 for my $i (0 .. scalar(@$tiles) - 1) {
915 61 100       87 next unless $tiles->[$i];
916 13         24 $start = $i;
917 13 100       14 last if grep { $_ eq qq{"$room"} } @{$tiles->[$i]};
  14         32  
  13         21  
918             }
919             # The first test refers to a tile that must be set to "empty" (where the stair
920             # will end), all others must be undefined. Note that stairs are anchored at
921             # the top end, and we're placing a stair that goes *down*. So what we're
922             # looking for is the point (4,1) in the image below:
923             #
924             # 12345
925             # 1 EE<<
926             # 2 EE
927             #
928             # Remember, +1 is east, -1 is west, -$row is north, +$row is south. The anchor
929             # point we're testing is already known to be undefined.
930 1         5 my %test = (n => [-2 * $self->row,
931             -$self->row - 1, -$self->row, -$self->row + 1,
932             -1, +1,
933             +$self->row - 1, +$self->row, +$self->row + 1],
934             e => [+2,
935             -$self->row + 1, +1, +$self->row + 1,
936             -$self->row, +$self->row,
937             -$self->row - 1, -1, +$self->row - 1]);
938 1         28 $test{s} = [map { -$_ } @{$test{n}}];
  9         13  
  1         3  
939 1         4 $test{w} = [map { -$_ } @{$test{e}}];
  9         11  
  1         4  
940             # First round: limit ourselves to stair positions close to the start.
941 1         4 my %candidates;
942 1         12 for my $here (shuffle 0 .. scalar(@$tiles) - 1) {
943 236 100       397 next if $tiles->[$here];
944 177         237 my $distance = $self->distance($here, $start);
945 177 100       351 $candidates{$here} = $distance if $distance <= 4;
946             }
947             # Second round: for each candidate, test stair placement and record the
948             # distance of the landing to the start and the direction of every successful
949             # stair.
950 1         8 my $stair;
951             my $stair_dir;
952 1         4 my $stair_distance = $self->max_tiles;
953 1         11 for my $here (sort {$a cmp $b} keys %candidates) {
  124         132  
954             # push(@{$tiles->[$here]}, "red");
955 33         68 for my $dir (shuffle qw(n e w s)) {
956 132         161 my @test = @{$test{$dir}};
  132         228  
957 132         166 my $first = shift(@test);
958 132 100 100     202 if (# the first test is an empty tile: this the stair's landing
959             $self->empty($tiles, $here, $first)
960             # and the stair is surrounded by empty space
961 143     143   229 and none { $self->something($tiles, $here, $_) } @test) {
962 5         15 my $distance = $self->distance($here + $first, $start);
963 5 100       24 if ($distance < $stair_distance) {
964             # $log->debug("Considering stair-$dir for $here ($distance)");
965 3         9 $stair = $here;
966 3         6 $stair_dir = $dir;
967 3         8 $stair_distance = $distance;
968             }
969             }
970             }
971             }
972 1 50       6 if (defined $stair) {
973 1         2 push(@{$tiles->[$stair]}, "stair-$stair_dir");
  1         5  
974 1         8 next STAIR;
975             }
976             # $log->debug("Unable to place a regular stair, trying to place a spiral staircase");
977 0         0 for my $here (shuffle 0 .. scalar(@$tiles) - 1) {
978 0 0       0 next unless $tiles->[$here];
979 0 0 0     0 if (# close by
      0        
      0        
      0        
980             $self->distance($here, $start) < 3
981             # and the landing is empty (no statue, doors n or w)
982 0         0 and @{$tiles->[$here]} == 1
983             and $tiles->[$here]->[0] eq "empty"
984             # and the landing to the south has no door n
985 0         0 and not grep { /-n$/ } @{$tiles->[$here+$self->row]}
  0         0  
986             # and the landing to the east has no door w
987 0         0 and not grep { /-w$/ } @{$tiles->[$here+1]}) {
  0         0  
988 0         0 $log->debug("Placed spiral stair at $here");
989 0         0 $tiles->[$here]->[0] = "stair-spiral";
990 0         0 next STAIR;
991             }
992             }
993 0         0 $log->warn("Unable to place a stair!");
994 0         0 next STAIR;
995             }
996 1         3 return $tiles;
997             }
998              
999             sub add_small_stair {
1000 0     0 0 0 my $self = shift;
1001 0         0 my $tiles = shift;
1002 0         0 my $stairs = shift;
1003 0         0 my %delta = (n => -$self->row, e => 1, s => $self->row, w => -1);
1004             STAIR:
1005 0         0 for my $room (@$stairs) {
1006             # find the middle using the label
1007 0         0 my $start;
1008 0         0 for my $i (0 .. scalar(@$tiles) - 1) {
1009 0 0       0 next unless $tiles->[$i];
1010 0         0 $start = $i;
1011 0 0       0 last if grep { $_ eq qq{"$room"} } @{$tiles->[$i]};
  0         0  
  0         0  
1012             }
1013 0         0 for (shuffle qw(n e w s)) {
1014 0 0       0 if (grep { $_ eq "empty" } @{$tiles->[$start + $delta{$_}]}) {
  0         0  
  0         0  
1015 0         0 push(@{$tiles->[$start + $delta{$_}]}, "stair-spiral");
  0         0  
1016 0         0 next STAIR;
1017             }
1018             }
1019             }
1020 0         0 return $tiles;
1021             }
1022              
1023             sub fix_corners {
1024 1     1 0 2 my $self = shift;
1025 1         3 my $tiles = shift;
1026 1         4 my %look = (n => -$self->row, e => 1, s => $self->row, w => -1);
1027 1         11 for my $here (0 .. scalar(@$tiles) - 1) {
1028 236         239 for (@{$tiles->[$here]}) {
  236         327  
1029 70 50       124 if (/^(arc|diagonal)-(ne|nw|se|sw)$/) {
1030 0         0 my $dir = $2;
1031             # debug_neighbours($tiles, $here);
1032 0 0 0     0 if (substr($dir, 0, 1) eq "n" and $here + $self->row < $self->max_tiles and $tiles->[$here + $self->row] and @{$tiles->[$here + $self->row]}
  0   0     0  
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
1033 0         0 or substr($dir, 0, 1) eq "s" and $here > $self->row and $tiles->[$here - $self->row] and @{$tiles->[$here - $self->row]}
1034 0         0 or substr($dir, 1) eq "e" and $here > 0 and $tiles->[$here - 1] and @{$tiles->[$here - 1]}
1035 0         0 or substr($dir, 1) eq "w" and $here < $self->max_tiles and $tiles->[$here + 1] and @{$tiles->[$here + 1]}) {
1036 0         0 $_ = "empty";
1037             }
1038             }
1039             }
1040             }
1041 1         4 return $tiles;
1042             }
1043              
1044             sub fix_pillars {
1045 1     1 0 2 my $self = shift;
1046 1         2 my $tiles = shift;
1047             # This is: $test{n}->[0] is straight ahead (e.g. looking north), $test{n}->[1]
1048             # is to the left (e.g. looking north-west), $test{n}->[2] is to the right
1049             # (e.g. looking north-east).
1050 1         5 my %test = (n => [-$self->row, -$self->row - 1, -$self->row + 1],
1051             e => [1, 1 - $self->row, 1 + $self->row],
1052             s => [$self->row, $self->row - 1, $self->row + 1],
1053             w => [-1, -1 - $self->row, -1 + $self->row]);
1054 1         27 for my $here (0 .. scalar(@$tiles) - 1) {
1055             TILE:
1056 236         243 for (@{$tiles->[$here]}) {
  236         304  
1057 70 50       109 if ($_ eq "pillar") {
1058             # $log->debug("$here: $_");
1059             # debug_neighbours($tiles, $here);
1060 0         0 for my $dir (qw(n e w s)) {
1061 0 0 0     0 if ($self->something($tiles, $here, $test{$dir}->[0])
      0        
1062             and not $self->something($tiles, $here, $test{$dir}->[1])
1063             and not $self->something($tiles, $here, $test{$dir}->[2])) {
1064             # $log->debug("Removing pillar $here");
1065 0         0 $_ = "empty";
1066 0         0 next TILE;
1067             }
1068             }
1069             }
1070             }
1071             }
1072 1         4 return $tiles;
1073             }
1074              
1075             sub to_rocks {
1076 0     0 0 0 my $self = shift;
1077 0         0 my $tiles = shift;
1078             # These are the directions we know (where m is the center). Order is important
1079             # so that list comparison is made easy.
1080 0         0 my @dirs = qw(n e w s);
1081 0         0 my %delta = (n => -$self->row, e => 1, s => $self->row, w => -1);
1082             # these are all the various rock configurations we know about; listed are the
1083             # fields that must be "empty" for this to work
1084 0         0 my %rocks = ("rock-n" => [qw(e w s)],
1085             "rock-ne" => [qw(w s)],
1086             "rock-ne-alternative" => [qw(w s)],
1087             "rock-e" => [qw(n w s)],
1088             "rock-se" => [qw(n w)],
1089             "rock-se-alternative" => [qw(n w)],
1090             "rock-s" => [qw(n e w)],
1091             "rock-sw" => [qw(n e)],
1092             "rock-sw-alternative" => [qw(n e)],
1093             "rock-w" => [qw(n e s)],
1094             "rock-nw" => [qw(e s)],
1095             "rock-nw-alternative" => [qw(e s)],
1096             "rock-dead-end-n" => [qw(s)],
1097             "rock-dead-end-e" => [qw(w)],
1098             "rock-dead-end-s" => [qw(n)],
1099             "rock-dead-end-w" => [qw(e)],
1100             "rock-corridor-n" => [qw(n s)],
1101             "rock-corridor-s" => [qw(n s)],
1102             "rock-corridor-e" => [qw(e w)],
1103             "rock-corridor-w" => [qw(e w)], );
1104             # my $first = 1;
1105 0         0 for my $here (0 .. scalar(@$tiles) - 1) {
1106             TILE:
1107 0         0 for (@{$tiles->[$here]}) {
  0         0  
1108 0 0       0 next unless grep { $_ eq "empty" } @{$tiles->[$here]};
  0         0  
  0         0  
1109 0 0       0 if (not $_) {
1110 0 0   0   0 $_ = "rock" if all { grep { $_ } $self->something($tiles, $here, $_) } qw(n e w s);
  0         0  
  0         0  
1111             } else {
1112             # loop through all the rock tiles and compare the patterns
1113             ROCK:
1114 0         0 for my $rock (keys %rocks) {
1115 0         0 my $expected = $rocks{$rock};
1116             my @actual = grep {
1117 0         0 my $dir = $_;
  0         0  
1118 0         0 $self->something($tiles, $here, $delta{$dir});
1119             } @dirs;
1120 0 0       0 if (list_equal($expected, \@actual)) {
1121 0         0 $_ = $rock;
1122 0         0 next TILE;
1123             }
1124             }
1125             }
1126             }
1127             }
1128 0         0 return $tiles;
1129             }
1130              
1131             sub list_equal {
1132 0     0 0 0 my $a1 = shift;
1133 0         0 my $a2 = shift;
1134 0 0       0 return 0 if @$a1 ne @$a2;
1135 0         0 for (my $i = 0; $i <= $#$a1; $i++) {
1136 0 0       0 return unless $a1->[$i] eq $a2->[$i];
1137             }
1138 0         0 return 1;
1139             }
1140              
1141             sub coordinates {
1142 0     0 0 0 my $self = shift;
1143 0         0 my $here = shift;
1144 0         0 return sprintf("%d,%d", int($here/$self->row), $here % $self->row);
1145             }
1146              
1147             sub legal {
1148 703     703 0 767 my $self = shift;
1149             # is this position on the map?
1150 703         725 my $here = shift;
1151 703         735 my $delta = shift;
1152 703 100 66     1464 return if $here + $delta < 0 or $here + $delta > $self->max_tiles;
1153 697 100 100     2660 return if $here % $self->row == 0 and $delta == -1;
1154 696 50 33     2364 return if $here % $self->row == $self->row and $delta == 1;
1155 696         3179 return 1;
1156             }
1157              
1158             sub something {
1159 571     571 0 690 my $self = shift;
1160             # Is there something at this legal position? Off the map means there is
1161             # nothing at the position.
1162 571         611 my $tiles = shift;
1163 571         613 my $here = shift;
1164 571         604 my $delta = shift;
1165 571 100       734 return if not $self->legal($here, $delta);
1166 570 100       1161 return @{$tiles->[$here + $delta]} if $tiles->[$here + $delta];
  368         957  
1167             }
1168              
1169             sub empty {
1170 132     132 0 152 my $self = shift;
1171             # Is this position legal and empty? We're looking for the "empty" tile!
1172 132         143 my $tiles = shift;
1173 132         145 my $here = shift;
1174 132         146 my $delta = shift;
1175 132 100       173 return if not $self->legal($here, $delta);
1176 126         145 return grep { $_ eq "empty" } @{$tiles->[$here + $delta]};
  49         203  
  126         289  
1177             }
1178              
1179             sub debug_neighbours {
1180 0     0 0 0 my $self = shift;
1181 0         0 my $tiles = shift;
1182 0         0 my $here = shift;
1183 0         0 my @n;
1184 0 0 0     0 if ($here > $self->row and $tiles->[$here - $self->row] and @{$tiles->[$here - $self->row]}) {
  0   0     0  
1185 0         0 push(@n, "n: @{$tiles->[$here - $self->row]}");
  0         0  
1186             }
1187 0 0 0     0 if ($here + $self->row <= $self->max_tiles and $tiles->[$here + $self->row] and @{$tiles->[$here + $self->row]}) {
  0   0     0  
1188 0         0 push(@n, "s: @{$tiles->[$here + $self->row]}");
  0         0  
1189             }
1190 0 0 0     0 if ($here > 0 and $tiles->[$here - 1] and @{$tiles->[$here - 1]}) {
  0   0     0  
1191 0         0 push(@n, "w: @{$tiles->[$here - 1]}");
  0         0  
1192             }
1193 0 0 0     0 if ($here < $self->max_tiles and $tiles->[$here + 1] and @{$tiles->[$here + 1]}) {
  0   0     0  
1194 0         0 push(@n, "e: @{$tiles->[$here + 1]}");
  0         0  
1195             }
1196 0         0 $log->debug("Neighbours of $here: @n");
1197 0         0 for (-$self->row-1, -$self->row, -$self->row+1, -1, +1, $self->row-1, $self->row, $self->row+1) {
1198 0         0 eval { $log->debug("Neighbours of $here+$_: @{$tiles->[$here + $_]}") };
  0         0  
  0         0  
1199             }
1200             }
1201              
1202             sub to_text {
1203 1     1 0 2 my $self = shift;
1204             # Don't forget the border of two tiles.
1205 1         3 my $tiles = shift;
1206 1         4 my $text = "include gridmapper.txt\n";
1207 1         4 for my $x (0 .. $self->row - 1) {
1208 14         27 for my $y (0 .. $self->col - 1) {
1209 266         410 my $tile = $tiles->[$x + $y * $self->row];
1210 266 100       815 if ($tile) {
1211 236         488 $text .= sprintf("%02d%02d @$tile\n", $x + 1, $y + 1);
1212             }
1213             }
1214             }
1215             # The following is matched in /gridmapper/random!
1216 1         5 my $url = $self->to_gridmapper_link($tiles);
1217 1         8 $text .= qq{other }
1218             . qq{Edit in Gridmapper\n};
1219 1         6 $text .= "# Gridmapper link: $url\n";
1220 1         27 return $text;
1221             }
1222              
1223             sub to_gridmapper_link {
1224 1     1 0 3 my $self = shift;
1225 1         3 my $tiles = shift;
1226 1         2 my $code;
1227 1         2 my $pen = 'up';
1228 1         3 for my $y (0 .. $self->col - 1) {
1229 19         54 for my $x (0 .. $self->row - 1) {
1230 266         434 my $tile = $tiles->[$x + $y * $self->row];
1231 266 100 100     999 if (not $tile or @$tile == 0) {
1232 206         304 my $next = $tiles->[$x + $y * $self->row + 1];
1233 206 50 66     700 if ($pen eq 'down' and $next and @$next) {
      66        
1234 0         0 $code .= ' ';
1235             } else {
1236 206         235 $pen = 'up';
1237             }
1238 206         264 next;
1239             }
1240 60 100       92 if ($pen eq 'up') {
1241 19         37 $code .= "($x,$y)";
1242 19         21 $pen = 'down';
1243             }
1244 60         71 my $finally = " ";
1245             # $log->debug("[$x,$y] @$tile");
1246 60         72 for (@$tile) {
1247 70 100       176 if ($_ eq "empty") { $finally = "f" }
  59 50       75  
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1248 0         0 elsif ($_ eq "pillar") { $code .= "p" }
1249 5         13 elsif (/^"(\d+)"$/) { $code .= $1 }
1250 0         0 elsif ($_ eq "arc-se") { $code .= "a" }
1251 0         0 elsif ($_ eq "arc-sw") { $code .= "aa" }
1252 0         0 elsif ($_ eq "arc-nw") { $code .= "aaa" }
1253 0         0 elsif ($_ eq "arc-ne") { $code .= "aaaa" }
1254 0         0 elsif ($_ eq "diagonal-se") { $code .= "n" }
1255 0         0 elsif ($_ eq "diagonal-sw") { $code .= "nn" }
1256 0         0 elsif ($_ eq "diagonal-nw") { $code .= "nnn" }
1257 0         0 elsif ($_ eq "diagonal-ne") { $code .= "nnnn" }
1258 0         0 elsif ($_ eq "door-w") { $code .= "d" }
1259 3         6 elsif ($_ eq "door-n") { $code .= "dd" }
1260 0         0 elsif ($_ eq "door-e") { $code .= "ddd" }
1261 0         0 elsif ($_ eq "door-s") { $code .= "dddd" }
1262 2         5 elsif ($_ eq "secret-w") { $code .= "dv" }
1263 0         0 elsif ($_ eq "secret-n") { $code .= "ddv" }
1264 0         0 elsif ($_ eq "secret-e") { $code .= "dddv" }
1265 0         0 elsif ($_ eq "secret-s") { $code .= "ddddv" }
1266 0         0 elsif ($_ eq "concealed-w") { $code .= "dvv" }
1267 0         0 elsif ($_ eq "concealed-n") { $code .= "ddvv" }
1268 0         0 elsif ($_ eq "concealed-e") { $code .= "dddvv" }
1269 0         0 elsif ($_ eq "concealed-s") { $code .= "ddddvv" }
1270 0         0 elsif ($_ eq "archway-w") { $code .= "dvvvv" }
1271 0         0 elsif ($_ eq "archway-n") { $code .= "ddvvvv" }
1272 0         0 elsif ($_ eq "archway-e") { $code .= "dddvvvv" }
1273 0         0 elsif ($_ eq "archway-s") { $code .= "ddddvvvv" }
1274 1         3 elsif ($_ eq "stair-s") { $code .= "s" }
1275 0         0 elsif ($_ eq "stair-w") { $code .= "ss" }
1276 0         0 elsif ($_ eq "stair-n") { $code .= "sss" }
1277 0         0 elsif ($_ eq "stair-e") { $code .= "ssss" }
1278 0         0 elsif ($_ eq "stair-spiral") { $code .= "svv" }
1279 0         0 elsif ($_ eq "rock") { $finally = "g" }
1280 0         0 elsif ($_ eq "rock-n") { $finally = "g" }
1281 0         0 elsif ($_ eq "rock-ne") { $finally = "g" }
1282 0         0 elsif ($_ eq "rock-ne-alternative") { $finally = "g" }
1283 0         0 elsif ($_ eq "rock-e") { $finally = "g" }
1284 0         0 elsif ($_ eq "rock-se") { $finally = "g" }
1285 0         0 elsif ($_ eq "rock-se-alternative") { $finally = "g" }
1286 0         0 elsif ($_ eq "rock-s") { $finally = "g" }
1287 0         0 elsif ($_ eq "rock-sw") { $finally = "g" }
1288 0         0 elsif ($_ eq "rock-sw-alternative") { $finally = "g" }
1289 0         0 elsif ($_ eq "rock-w") { $finally = "g" }
1290 0         0 elsif ($_ eq "rock-nw") { $finally = "g" }
1291 0         0 elsif ($_ eq "rock-nw-alternative") { $finally = "g" }
1292 0         0 elsif ($_ eq "rock-dead-end-n") { $finally = "g" }
1293 0         0 elsif ($_ eq "rock-dead-end-e") { $finally = "g" }
1294 0         0 elsif ($_ eq "rock-dead-end-s") { $finally = "g" }
1295 0         0 elsif ($_ eq "rock-dead-end-w") { $finally = "g" }
1296 0         0 elsif ($_ eq "rock-corridor-n") { $finally = "g" }
1297 0         0 elsif ($_ eq "rock-corridor-s") { $finally = "g" }
1298 0         0 elsif ($_ eq "rock-corridor-e") { $finally = "g" }
1299 0         0 elsif ($_ eq "rock-corridor-w") { $finally = "g" }
1300             else {
1301 0         0 $log->warn("Tile $_ not known for Gridmapper link");
1302             }
1303             }
1304 60         75 $code .= $finally;
1305             }
1306 19         26 $pen = 'up';
1307             }
1308 1         11 $log->debug("Gridmapper: $code");
1309 1         16 my $url = 'https://campaignwiki.org/gridmapper?' . url_escape($code);
1310 1         128 return $url;
1311             }
1312              
1313             =head1 SEE ALSO
1314              
1315             L is a web
1316             application that lets you draw dungeons with strong focus on using the keyboard.
1317              
1318             =cut
1319              
1320             1;