File Coverage

blib/lib/Game/TextMapper/Mapper.pm
Criterion Covered Total %
statement 229 255 89.8
branch 61 84 72.6
condition 27 38 71.0
subroutine 22 22 100.0
pod 2 15 13.3
total 341 414 82.3


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::Mapper - a text map parser and builder
21              
22             =head1 SYNOPSIS
23              
24             use Modern::Perl;
25             use Game::TextMapper::Mapper::Hex;
26             my $map = <
27             0101 forest
28             include default.txt
29             EOT
30             my $svg = Game::TextMapper::Mapper::Hex->new(dist_dir => 'share')
31             ->initialize($map)
32             ->svg();
33             print $svg;
34              
35             =head1 DESCRIPTION
36              
37             This class knows how to parse a text containing a map description into SVG
38             definitions, and regions. Once the map is built, this class knows how to
39             generate the SVG for the entire map.
40              
41             The details depend on whether the map is a hex map or a square map. You should
42             use the appropriate class instead of this one: L
43             or L.
44              
45             =cut
46              
47             package Game::TextMapper::Mapper;
48 1     1   496 use Game::TextMapper::Log;
  1         1  
  1         26  
49 1     1   5 use Modern::Perl '2018';
  1         2  
  1         4  
50 1     1   98 use Mojo::UserAgent;
  1         2  
  1         12  
51 1     1   25 use Mojo::Base -base;
  1         2  
  1         3  
52 1     1   478 use File::Slurper qw(read_text);
  1         2522  
  1         48  
53 1     1   7 use Encode qw(decode_utf8);
  1         2  
  1         37  
54 1     1   416 use File::ShareDir 'dist_dir';
  1         20925  
  1         4089  
55              
56             =head1 ATTRIBUTES
57              
58             =head2 dist_dir
59              
60             You need to pass this during instantiation so that the mapper knows where to
61             find files it needs to include.
62              
63             =cut
64              
65             has 'dist_dir';
66             has 'map';
67             has 'regions' => sub { [] };
68             has 'attributes' => sub { {} };
69             has 'defs' => sub { [] };
70             has 'path' => sub { {} };
71             has 'lines' => sub { [] };
72             has 'things' => sub { [] };
73             has 'path_attributes' => sub { {} };
74             has 'text_attributes' => '';
75             has 'glow_attributes' => '';
76             has 'label_attributes' => '';
77             has 'messages' => sub { [] };
78             has 'seen' => sub { {} };
79             has 'license' => '';
80             has 'other' => sub { [] };
81             has 'url' => '';
82             has 'offset' => sub { [] };
83              
84             my $log = Game::TextMapper::Log->get;
85              
86             sub example {
87 1     1 0 3 return <<"EOT";
88             0101 mountain "mountain"
89             0102 swamp "swamp"
90             0103 hill "hill"
91             0104 forest "forest"
92             0201 empty pyramid "pyramid"
93             0202 tundra "tundra"
94             0203 coast "coast"
95             0204 empty house "house"
96             0301 woodland "woodland"
97             0302 wetland "wetland"
98             0303 plain "plain"
99             0304 sea "sea"
100             0401 hill tower "tower"
101             0402 sand house "house"
102             0403 jungle "jungle"
103             0501 mountain cave "cave"
104             0502 sand "sand"
105             0503 hill castle "castle"
106             0205-0103-0202-0303-0402 road
107             0101-0203 river
108             0401-0303-0403 border
109             include default.txt
110             license Public Domain
111             EOT
112             }
113              
114             =head1 METHODS
115              
116             =head2 initialize($map)
117              
118             Call this to load a map into the mapper.
119              
120             =cut
121              
122             sub initialize {
123 10     10 1 120 my ($self, $map) = @_;
124 10         80 $map =~ s/-/-/g; # -- are invalid in source comments...
125 10         64 $self->map($map);
126 10         1573 $self->process(split(/\r?\n/, $map));
127             }
128              
129             sub process {
130 18     18 0 3298 my $self = shift;
131 18         33 my $line_id = 0;
132 18         47 foreach (@_) {
133 3855 100       25345 if (/^(-?\d\d)(-?\d\d)(\d\d)?\s+(.*)/) {
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
134 2507   50     7867 my $region = $self->make_region(x => $1, y => $2, z => $3||'00', map => $self);
135 2507         17581 my $rest = $4;
136 2507         5742 while (my ($tag, $label, $size) = $rest =~ /\b([a-z]+)=["“]([^"”]+)["”]\s*(\d+)?/) {
137 74 100       143 if ($tag eq 'name') {
138 37         92 $region->label($label);
139 37         197 $region->size($size);
140             }
141 74         1243 $rest =~ s/\b([a-z]+)=["“]([^"”]+)["”]\s*(\d+)?//;
142             }
143 2507         4773 while (my ($label, $size) = $rest =~ /["“]([^"”]+)["”]\s*(\d+)?/) {
144 5         16 $region->label($label);
145 5         39 $region->size($size);
146 5         40 $rest =~ s/["“]([^"”]+)["”]\s*(\d+)?//;
147             }
148 2507         5677 my @types = split(/\s+/, $rest);
149 2507         5969 $region->type(\@types);
150 2507         10774 push(@{$self->regions}, $region);
  2507         3782  
151 2507         8177 push(@{$self->things}, $region);
  2507         3602  
152             } elsif (/^(-?\d\d-?\d\d(?:\d\d)?(?:--?\d\d-?\d\d(?:\d\d)?)+)\s+(\S+)\s*(?:["“](.+)["”])?/) {
153 329         733 my $line = $self->make_line(map => $self);
154 329         1955 my $str = $1;
155 329         728 $line->type($2);
156 329         1874 $line->label($3);
157 329         1859 $line->id('line' . $line_id++);
158 329         1436 my @points;
159 329         1024 while ($str =~ /\G(-?\d\d)(-?\d\d)(\d\d)?-?/cg) {
160 1770   50     14489 push(@points, Game::TextMapper::Point->new(x => $1, y => $2, z => $3||'00'));
161             }
162 329         2753 $line->points(\@points);
163 329         1428 push(@{$self->lines}, $line);
  329         584  
164             } elsif (/^(\S+)\s+attributes\s+(.*)/) {
165 136         277 $self->attributes->{$1} = $2;
166             } elsif (/^(\S+)\s+lib\s+(.*)/) {
167 0         0 $self->def(qq{$2});
168             } elsif (/^(\S+)\s+xml\s+(.*)/) {
169 26         88 $self->def(qq{$2});
170             } elsif (/^(<.*>)/) {
171 443         705 $self->def($1);
172             } elsif (/^(\S+)\s+path\s+attributes\s+(.*)/) {
173 36         89 $self->path_attributes->{$1} = $2;
174             } elsif (/^(\S+)\s+path\s+(.*)/) {
175 15         32 $self->path->{$1} = $2;
176             } elsif (/^text\s+(.*)/) {
177 8         44 $self->text_attributes($1);
178             } elsif (/^glow\s+(.*)/) {
179 7         32 $self->glow_attributes($1);
180             } elsif (/^label\s+(.*)/) {
181 8         44 $self->label_attributes($1);
182             } elsif (/^license\s+(.*)/) {
183 5         41 $self->license($1);
184             } elsif (/^other\s+(.*)/) {
185 8         11 push(@{$self->other()}, $1);
  8         22  
186             } elsif (/^url\s+(\S+)/) {
187 0         0 $self->url($1);
188             } elsif (/^include\s+(\S*)/) {
189 8 50       17 if (scalar keys %{$self->seen} > 5) {
  8 50       49  
190 0         0 push(@{$self->messages},
  0         0  
191             "Includes are limited to five to prevent loops");
192             } elsif (not $self->seen->{$1}) {
193 8         64 my $location = $1;
194 8         25 $self->seen->{$location} = 1;
195 8         75 my $path = Mojo::File->new($self->dist_dir, $location);
196 8 50 33     329 if (index($location, '/') == -1 and -f $path) {
    0          
    0          
197             # without a slash, it could be a file from dist_dir
198 8         415 $log->debug("Reading $location");
199 8         128 $self->process(split(/\n/, decode_utf8($path->slurp())));
200             } elsif ($location =~ /^https?:/) {
201 0         0 $log->debug("Getting $location");
202 0         0 my $ua = Mojo::UserAgent->new;
203 0         0 my $response = $ua->get($location)->result;
204 0 0       0 if ($response->is_success) {
205 0         0 $self->process(split(/\n/, $response->text));
206             } else {
207 0         0 push(@{$self->messages}, "Getting $location: " . $response->status_line);
  0         0  
208             }
209             } elsif ($self->dist_dir =~ /^https?:/) {
210 0         0 my $url = $self->dist_dir;
211 0 0       0 $url .= '/' unless $url =~ /\/$/;
212 0         0 $url .= $location;
213 0         0 $log->debug("Getting $url");
214 0         0 my $ua = Mojo::UserAgent->new;
215 0         0 my $response = $ua->get($url)->result;
216 0 0       0 if ($response->is_success) {
217 0         0 $self->process(split(/\n/, $response->text));
218             } else {
219 0         0 push(@{$self->messages}, "Getting $url: " . $response->status_line);
  0         0  
220             }
221             } else {
222 0         0 $log->warn("No library '$location' in " . $self->dist_dir);
223 0         0 push(@{$self->messages}, "Library '$location' is must be an existing file on the server or a HTTP/HTTPS URL");
  0         0  
224             }
225             }
226             } else {
227 319 50 66     869 $log->debug("Did not parse $_") if $_ and not /^\s*#/;
228             }
229             }
230 18         188 return $self;
231             }
232              
233             sub def {
234 469     469 0 1278 my ($self, $svg) = @_;
235 469         1984 $svg =~ s/>\s+
236 469         590 push(@{$self->defs}, $svg);
  469         741  
237             }
238              
239             sub merge_attributes {
240 462     462 0 2104 my %attr = ();
241 462         593 for my $attr (@_) {
242 693 100       1251 if ($attr) {
243 68         339 while ($attr =~ /(\S+)=((["']).*?\3)/g) {
244 104         418 $attr{$1} = $2;
245             }
246             }
247             }
248 462         963 return join(' ', map { $_ . '=' . $attr{$_} } sort keys %attr);
  104         334  
249             }
250              
251             sub svg_header {
252 9     9 0 23 my ($self) = @_;
253              
254 9         35 my $header = qq{
255            
256             xmlns:xlink="http://www.w3.org/1999/xlink"
257             };
258 9 50       16 return $header . "\n" unless @{$self->regions};
  9         24  
259 9         55 my $maxz = 0;
260 9         20 foreach my $region (@{$self->regions}) {
  9         34  
261 2507 50       9330 $maxz = $region->z if $region->z > $maxz;
262             }
263             # these are required to calculate the viewBox for the SVG
264 9         57 my $min_x_overall;
265             my $max_x_overall;
266 9         0 my $min_y_overall;
267             # $max_y_overall is the last row of the SVG with all the levels: if there is
268             # just one hex, 010100, then the last row shown on the SVG is 0 (the first
269             # one); if there are two hexes beneath each other, 010100 and 010101, then the
270             # last row shown on the SVG is 2 (y=0 is for z=0, y=1 is the space between
271             # levels, and y=2 is for z=1); note that this would be the same if the two
272             # hexes were 020200 and 020202!
273 9         17 my $max_y_overall = 0;
274 9         38 for my $z (0 .. $maxz) {
275 9         15 my ($minx, $miny, $maxx, $maxy);
276 9 50       34 $max_y_overall += 1 if $z > 0;
277 9         42 $self->offset->[$z] = $max_y_overall;
278 9         21 foreach my $region (@{$self->regions}) {
  9         27  
279 2507 50       10775 next unless $region->z == $z;
280 2507 100 66     10448 $minx = $region->x unless defined $minx and $minx <= $region->x;
281 2507 100 100     11445 $maxx = $region->x unless defined $maxx and $maxx >= $region->x;
282 2507 100 66     11596 $miny = $region->y unless defined $miny and $miny <= $region->y;
283 2507 100 100     11333 $maxy = $region->y unless defined $maxy and $maxy >= $region->y;
284             }
285 9 50 33     57 $min_x_overall = $minx unless defined $min_x_overall and $minx >= $min_x_overall;
286 9 50 33     28 $max_x_overall = $maxx unless defined $min_y_overall and $maxx <= $max_x_overall;;
287 9 50       22 $min_y_overall = $miny unless defined $min_y_overall;
288 9         36 $max_y_overall += 1 + $maxy - $miny;
289             }
290 9         48 my ($vx1, $vy1, $vx2, $vy2) = $self->viewbox($min_x_overall, $min_y_overall, $max_x_overall, $max_y_overall);
291 9         31 my ($width, $height) = ($vx2 - $vx1, $vy2 - $vy1);
292 9         51 $header .= qq{ viewBox="$vx1 $vy1 $width $height">\n};
293 9         41 $header .= qq{ \n};
294 9         29 return $header;
295             }
296              
297             sub svg_defs {
298 9     9 0 24 my ($self) = @_;
299             # All the definitions are included by default.
300 9         16 my $doc = " \n";
301 9 100       14 $doc .= " " . join("\n ", @{$self->defs}, "") if @{$self->defs};
  7         48  
  9         26  
302             # collect region types from attributess and paths in case the sets don't overlap
303 9         259 my %types = ();
304 9         25 foreach my $region (@{$self->regions}) {
  9         30  
305 2507         2894 foreach my $type (@{$region->type}) {
  2507         3338  
306 3943         8773 $types{$type} = 1;
307             }
308             }
309 9         27 foreach my $line (@{$self->lines}) {
  9         42  
310 329         1133 $types{$line->type} = 1;
311             }
312             # now go through them all
313 9         145 foreach my $type (sort keys %types) {
314 231         388 my $path = $self->path->{$type};
315 231         784 my $attributes = merge_attributes($self->attributes->{$type});
316             my $path_attributes = merge_attributes($self->path_attributes->{'default'},
317 231         462 $self->path_attributes->{$type});
318 231         511 my $glow_attributes = $self->glow_attributes;
319 231 100 100     1098 if ($path || $attributes) {
320 52         134 $doc .= qq{ \n};
321             # just shapes get a glow such, eg. a house (must come first)
322 52 100 100     118 if ($path && !$attributes) {
323 3         14 $doc .= qq{ \n}
324             }
325             # region with attributes get a shape (square or hex), eg. plains and grass
326 52 100       75 if ($attributes) {
327 49         107 $doc .= " " . $self->shape($attributes) . "\n";
328             }
329             # and now the attributes themselves the shape itself
330 52 100       104 if ($path) {
331 8         20 $doc .= qq{ \n}
332             }
333             # close
334 52         113 $doc .= qq{ \n};
335             } else {
336             # nothing
337             }
338             }
339 9         204 $doc .= qq{ \n};
340             }
341              
342             sub svg_backgrounds {
343 9     9 0 19 my $self = shift;
344 9         27 my $doc = qq{ \n};
345 9         19 foreach my $thing (@{$self->things}) {
  9         27  
346             # make a copy
347 2507         11262 my @types = @{$thing->type};
  2507         3715  
348             # keep attributes
349 2507         8736 $thing->type([grep { $self->attributes->{$_} } @{$thing->type}]);
  3943         12979  
  2507         3502  
350 2507         17736 $doc .= $thing->svg($self->offset);
351             # reset copy
352 2507         4678 $thing->type(\@types);
353             }
354 9         52 $doc .= qq{ \n};
355 9         474 return $doc;
356             }
357              
358             sub svg_things {
359 9     9 0 18 my $self = shift;
360 9         20 my $doc = qq{ \n};
361 9         24 foreach my $thing (@{$self->things}) {
  9         30  
362             # drop attributes
363 2507         2813 $thing->type([grep { not $self->attributes->{$_} } @{$thing->type}]);
  3943         13906  
  2507         3785  
364 2507         17964 $doc .= $thing->svg($self->offset);
365             }
366 9         23 $doc .= qq{ \n};
367 9         337 return $doc;
368             }
369              
370             sub svg_coordinates {
371 9     9 0 20 my $self = shift;
372 9         21 my $doc = qq{ \n};
373 9         20 foreach my $region (@{$self->regions}) {
  9         39  
374 2507         4438 $doc .= $region->svg_coordinates($self->offset);
375             }
376 9         32 $doc .= qq{ \n};
377 9         366 return $doc;
378             }
379              
380             sub svg_lines {
381 9     9 0 20 my $self = shift;
382 9         24 my $doc = qq{ \n};
383 9         19 foreach my $line (@{$self->lines}) {
  9         28  
384 329         720 $doc .= $line->svg($self->offset);
385             }
386 9         46 $doc .= qq{ \n};
387 9         140 return $doc;
388             }
389              
390             sub svg_regions {
391 9     9 0 24 my $self = shift;
392 9         23 my $doc = qq{ \n};
393 9   100     32 my $attributes = $self->attributes->{default} || qq{fill="none"};
394 9         70 foreach my $region (@{$self->regions}) {
  9         24  
395 2507         21445 $doc .= $region->svg_region($attributes, $self->offset);
396             }
397 9         791 $doc .= qq{ \n};
398             }
399              
400             sub svg_line_labels {
401 9     9 0 21 my $self = shift;
402 9         19 my $doc = qq{ \n};
403 9         18 foreach my $line (@{$self->lines}) {
  9         39  
404 329         1513 $doc .= $line->svg_label($self->offset);
405             }
406 9         63 $doc .= qq{ \n};
407 9         65 return $doc;
408             }
409              
410             sub svg_labels {
411 9     9 0 20 my $self = shift;
412 9         21 my $doc = qq{ \n};
413 9         15 foreach my $region (@{$self->regions}) {
  9         29  
414 2507         10184 $doc .= $region->svg_label($self->url, $self->offset);
415             }
416 9         54 $doc .= qq{ \n};
417 9         40 return $doc;
418             }
419              
420             =head2 svg()
421              
422             This method generates the SVG once the map is initialized.
423              
424             =cut
425              
426             sub svg {
427 9     9 1 22 my ($self) = @_;
428              
429 9         63 my $doc = $self->svg_header();
430 9         47 $doc .= $self->svg_defs();
431 9         58 $doc .= $self->svg_backgrounds(); # opaque backgrounds
432 9         83 $doc .= $self->svg_lines();
433 9         56 $doc .= $self->svg_things(); # icons, lines
434 9         50 $doc .= $self->svg_coordinates();
435 9         56 $doc .= $self->svg_regions();
436 9         63 $doc .= $self->svg_line_labels();
437 9         47 $doc .= $self->svg_labels();
438 9   100     41 $doc .= $self->license() ||'';
439 9         93 $doc .= join("\n", @{$self->other()}) . "\n";
  9         35  
440              
441             # error messages
442 9         37 my $y = 10;
443 9         18 foreach my $msg (@{$self->messages}) {
  9         42  
444 0         0 $doc .= " $msg\n";
445 0         0 $y += 10;
446             }
447              
448             # source code (comments may not include -- for SGML compatibility!)
449             # https://stackoverflow.com/questions/10842131/xml-comments-and
450 9         41 my $source = $self->map();
451 9         139 $source =~ s/--/--/g;
452 9         134 $doc .= "\n";
453 9         35 $doc .= qq{\n};
454              
455 9         895 return $doc;
456             }
457              
458             =head1 SEE ALSO
459              
460             L is for hex maps.
461              
462             L is for square maps.
463              
464             =cut
465              
466             1;