File Coverage

lib/Traveller/Mapper.pm

Criterion	Covered	Total	%
statement	13	273	4.7
branch	0	84	0.0
condition	0	98	0.0
subroutine	5	24	20.8
pod	0	20	0.0
total	18	499	3.6

line	stmt	bran	cond	sub	pod	time	code
1							# Copyright (C) 2009-2021 Alex Schroeder
2							# Copyright (C) 2020 Christian Carey
3							#
4							# This program is free software: you can redistribute it and/or modify it under
5							# the terms of the GNU General Public License as published by the Free Software
6							# Foundation, either version 3 of the License, or (at your option) any later
7							# version.
8							#
9							# This program is distributed in the hope that it will be useful, but WITHOUT
10							# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
11							# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
12							#
13							# You should have received a copy of the GNU General Public License along with
14							# this program. If not, see .
15							#
16							# Algorithms based on Traveller ©2008 Mongoose Publishing.
17
18							package Traveller::Mapper;
19	2			2		1086	use List::Util qw(shuffle reduce);
	2					5
	2					131
20	2			2		8	use Mojo::Base -base;
	2					4
	2					11
21	2			2		382	use Traveller::Util qw(nearby distance in);
	2					4
	2					94
22	2			2		783	use Traveller::Hex;
	2					5
	2					9
23
24							has 'hexes' => sub { [] };
25							has 'routes' => sub { [] };
26							has 'comm_set';
27							has 'trade_set';
28							has 'source';
29							has 'width';
30							has 'height';
31
32							my $colour_re = qr/#([0-9a-f]{3}){1,2}/i;
33
34							my $example = q!Inedgeus 0101 D7A5579-8 G Fl Ni A
35							Geaan 0102 E66A999-7 G Hi Wa A
36							Orgemaso 0103 C555875-5 SG Ga Lt
37							Veesso 0105 C5A0369-8 G De Lo A
38							Ticezale 0106 B769799-7 T SG Ri A
39							Maatonte 0107 C6B3544-8 C G Fl Ni A
40							Diesra 0109 D510522-8 SG Ni
41							Esarra 0204 E869100-8 G Lo A
42							Rience 0205 C687267-8 G Ga Lo
43							Rearreso 0208 C655432-5 C G Ga Lt Ni
44							Laisbe 0210 E354663-3 Ag Lt Ni
45							Biveer 0302 C646576-9 C G Ag Ga Ni
46							Labeveri 0303 A796100-9 CT N G Ga Lo A
47							Sotexe 0408 E544778-3 G Ag Ga Lt A
48							Zamala 0409 A544658-13 T N G Ag Ga Ht Ni
49							Sogeeran 0502 A200443-14 CT N G Ht Ni Va
50							Aanbi 0503 E697102-7 G Ga Lo A
51							Bemaat 0504 C643384-9 C R G Lo Po
52							Diare 0505 A254430-11 TRN G Ni A
53							Esgeed 0507 A8B1579-11 RN G Fl Ni A
54							Leonbi 0510 B365789-9 T SG Ag Ri A
55							Reisbeon 0604 C561526-8 R G Ni
56							Atcevein 0605 A231313-11 CT G Lo Po
57							Usmabe 0607 A540A84-15 T G De Hi Ht In Po
58							Onbebior 0608 B220530-10 G De Ni Po A
59							Raraxema 0609 B421768-8 T NSG Na Po
60							Xeerri 0610 C210862-9 G Na
61							Onreon 0702 D8838A9-2 S Lt Ri A
62							Ismave 0703 E272654-4 Lt Ni
63							Lara 0704 C0008D9-5 SG As Lt Na Va A
64							Lalala 0705 C140473-9 R G De Ni Po
65							Maxereis 0707 A55A747-12 CT NSG Ht Wa
66							Requbire 0802 C9B4200-10 G Fl Lo A
67							Azaxe 0804 B6746B9-8 C G Ag Ga Ni A
68							Rieddige 0805 B355578-7 G Ag Ni A
69							Usorce 0806 E736110-3 G Lo Lt A
70							Solacexe 0810 D342635-4 P S Lt Ni Po R
71							!;
72
73							sub example {
74	1			1	0	7	return $example;
75							}
76
77							# The empty hex is centered around 0,0 and has a side length of 1,
78							# a maximum diameter of 2, and a minimum diameter of √3.
79							my @hex = ( -1, 0,
80							-0.5, sqrt(3)/2,
81							0.5, sqrt(3)/2,
82							1, 0,
83							0.5, -sqrt(3)/2,
84							-0.5, -sqrt(3)/2);
85
86							sub header {
87	0			0	0		my ($self, $width, $height) = @_;
88							# TO DO: support an option for North American “A” paper dimensions (width 215.9 mm, length 279.4 mm)
89	0		0				$width //= 210;
90	0		0				$height //= 297;
91	0						my $template = <
92
93
94							xmlns:xlink="http://www.w3.org/1999/xlink"
95							width="${width}mm"
96							height="${height}mm"
97							viewBox="%s %s %s %s">
98							Traveller Subsector
99
100
161
162
163
164
165							x="%s" y="%s" width="%s" height="%s" />
166
167							EOT
168	0						my $scale = 100;
169							return sprintf($template,
170	0						map { sprintf("%.3f", $_ * $scale) }
	0
171							# viewport
172							-0.5, -0.5, 3 + ($self->width - 1) * 1.5, ($self->height + 1.5) * sqrt(3),
173							# empty hex, once for the backgrounds and once for the stroke
174							@hex,
175							@hex,
176							# framing rectangle
177							-0.5, -0.5, 3 + ($self->width - 1) * 1.5, ($self->height + 1.5) * sqrt(3));
178							}
179
180							sub colour {
181	0			0	0		my $self = shift;
182	0	0					my $culture = shift or return "white";
183							# The same colours result from the same names.
184	0						my @colours = ("#d3d3d3", "#f5f5f5", "#eaeaea", "#fffeb0", "#fff0f5", "#eee0e5", "#ffe1ff",
185							"#eed2ee", "#c6e2ff", "#fdf5e6", "#e0ffff", "#d1eeee", "#c5fff5", "#eeeee0",
186							"#fff68f", "#eee685", "#fffacd", "#eee9bf", "#ffe7ba", "#ffefdb", "#ffe4e1",
187							"#eed5d2", "#e6e6fa", "#f0ffff", "#c5ffd5", "#e6ffe6", "#d5ffc5", "#f5f5dc");
188	0						my $i = unpack("%32W*", lc $culture) % @colours; # checksum
189	0						return $colours[$i];
190							}
191
192							sub background {
193	0			0	0		my $self = shift;
194	0						my $scale = 100;
195							return join("\n", map {
196	0						my $hex = $_;
197	0						my $x = $hex->x;
198	0						my $y = $hex->y;
199	0		0				my $c = $hex->colour \|\| $self->colour($hex->culture);
200	0						sprintf(qq{ },
201							(1 + ($x-1) * 1.5) * $scale,
202							($y - $x%2/2) * sqrt(3) * $scale);
203	0						} @{$self->hexes});
	0
204							}
205
206							sub grid {
207	0			0	0		my $self = shift;
208	0						my $scale = 100;
209	0						my $doc;
210							$doc .= join("\n",
211							map {
212	0						my $n = shift;
	0
213	0						my $x = int($_/$self->height+1);
214	0						my $y = $_ % $self->height + 1;
215	0						my $svg = sprintf(qq{ \n},
216							(1 + ($x-1) * 1.5) * $scale,
217							($y - $x%2/2) * sqrt(3) * $scale);
218	0						$svg .= sprintf(qq{ }
219							. qq{%02d%02d\n},
220							(1 + ($x-1) * 1.5) * $scale,
221							($y - $x%2/2) * sqrt(3) * $scale - 0.6 * $scale,
222							$x, $y);
223							} (0 .. $self->width * $self->height - 1));
224	0						return $doc;
225							}
226
227							sub legend {
228	0			0	0		my $self = shift;
229	0						my $scale = 100;
230	0						my $doc;
231	0						my $uwp = '';
232	0	0					if ($self->source) {
233	0						$uwp = ' – UWP';
234							}
235	0						$doc .= sprintf(qq{ ◉ gas giant}
236							. qq{ – ■ Imperial consulate – ☼ TAS facility – ▲ scout base}
237							. qq{ – ★ naval base – π research station – ☠ pirate base}
238							. qq{ – ▮ communication}
239							. qq{ – ▮ trade$uwp\n},
240							-10, ($self->height + 1) * sqrt(3) * $scale);
241	0						$doc .= sprintf(qq{ coreward\n},
242							$self->width/2 * 1.5 * $scale, -0.13 * $scale);
243	0						$doc .= sprintf(qq{
244							. qq{ class="direction">trailing\n},
245							($self->width + 0.4) * 1.5 * $scale, $self->height/2 * sqrt(3) * $scale);
246	0						$doc .= sprintf(qq{ rimward\n},
247							$self->width/2 * 1.5 * $scale, ($self->height + 0.7) * sqrt(3) * $scale);
248	0						$doc .= sprintf(qq{
249							. qq{ class="direction">spinward\n},
250							-0.1 * $scale, $self->height/2 * sqrt(3) * $scale);
251	0						return $doc;
252							}
253
254							sub footer {
255	0			0	0		my $self = shift;
256	0						my $doc;
257	0						my $y = 10;
258	0						my $debug = ''; # for developers
259	0						for my $line (split(/\n/, $debug)) {
260	0						$doc .= qq{}
261							. $line . qq{\n};
262	0						$y += 20;
263							}
264	0						$doc .= qq{\n};
265	0						return $doc;
266							}
267
268							sub initialize {
269	0			0	0		my ($self, $map, $wiki, $source) = @_;
270	0						$self->source($source);
271	0						$self->width(0);
272	0						$self->height(0);
273	0						my @lines = split(/\n/, $map);
274	0						$self->initialize_map($wiki, \@lines);
275	0						$self->initialize_routes(\@lines);
276							}
277
278							sub initialize_map {
279	0			0	0		my ($self, $wiki, $lines) = @_;
280	0						foreach (@$lines) {
281							# parse Traveller UWP, with optional name
282	0						my ($name, $x, $y,
283							$starport, $size, $atmosphere, $hydrographic, $population,
284							$government, $law, $tech, $bases, $rest) =
285							/(?:([^>\r\n\t]?)\s+)?(\d\d)(\d\d)\s+([A-EX])([\dA])([\dA-F])([\dA])([\dA-C])([\dA-F])([\dA-L])-(\d{1,2}\|[\dA-HJ-NP-Z])(?:\s+([PCTRNSG ]+)\b)?(.)/;
286							# alternative super simple name, coordinates, optional size (0-9), optional bases (PCTRNSG), optional travel zones (AR)
287	0	0	0				($name, $x, $y, $size, $bases, $rest) =
288							/([^>\r\n\t]?)\s+(\d\d)(\d\d)(?:\s+(\d)\b)?(?:\s+([PCTRNSG ]+)\b)?(.)/
289							unless $x and $y;
290	0	0	0				next unless $x and $y;
291	0	0					$self->width($x) if $x > $self->width;
292	0	0					$self->height($y) if $y > $self->height;
293	0						my @tokens = split(' ', $rest);
294	0						my @colours = grep(/^$colour_re$/, @tokens);
295	0						my %trade = map { $_ => 1 } grep(/^[A-Z][A-Za-z]$/, @tokens);
	0
296	0						my ($culture) = grep /^\[.*\]$/, @tokens; # culture in square brackets
297	0						my ($travelzone) = grep /^([AR])$/, @tokens; # amber or red travel zone
298							# avoid uninitialized values warnings in the rest of the code
299	0		0				map { $$_ //= '' } (\$size,
	0
300							\$atmosphere,
301							\$hydrographic,
302							\$population,
303							\$government,
304							\$law,
305							\$starport,
306							\$travelzone);
307							# get "hex" values, but accept letters beyond F! (excepting I and O)
308	0	0	0				map { $$_ = $$_ ge 'P' and $$_ le 'Z' ? 23 + ord($$_) - 80
	0	0	0
		0
		0
		0
309							: $$_ ge 'J' and $$_ le 'N' ? 18 + ord($$_) - 74
310							: $$_ ge 'A' and $$_ le 'H' ? 10 + ord($$_) - 65
311							: $$_ eq '' ? 0
312							: $$_ } (\$size,
313							\$atmosphere,
314							\$hydrographic,
315							\$population,
316							\$government,
317							\$law);
318	0		0				my $hex = Traveller::Hex->new(
			0
319							name => $name,
320							x => $x,
321							y => $y,
322							starport => $starport,
323							population => $population,
324							size => $size,
325							travelzone => $travelzone,
326							trade => \%trade,
327							culture => $culture // '',
328							colour => shift(@colours) \|\| $self->colour($culture));
329	0	0					$hex->url("$wiki$name") if $wiki;
330	0	0					if ($bases) {
331	0						for my $base (split(//, $bases)) {
332	0						$hex->base($base);
333							}
334							}
335	0						$self->add($hex);
336							}
337							}
338
339							sub add {
340	0			0	0		my ($self, $hex) = @_;
341	0						push(@{$self->hexes}, $hex);
	0
342							}
343
344							sub initialize_routes {
345	0			0	0		my ($self, $lines) = @_;
346	0						foreach (@$lines) {
347							# parse non-standard routes
348	0						my ($from, $to, $type, $colour) = /^(\d\d\d\d)-(\d\d\d\d)\s+(C\|T)\b\s*($colour_re)?/i;
349	0	0					next unless $type;
350	0	0					if (lc($type) eq 'c') {
351	0						$self->comm_set(1); # at least one hex here has comm
352	0						push(@{$self->at($from)->comm}, $self->at($to)); # a property of the hex
	0
353							} else {
354	0						$self->trade_set(1); # at least one hex here has trade
355	0						my $from_hex = $self->at($from);
356	0						my $to_hex = $self->at($to);
357
358	0						push(@{$self->routes}, [$from_hex, $to_hex]); # a property of the mapper
	0
359							}
360							}
361							}
362
363							sub at {
364	0			0	0		my ($self, $coord) = @_;
365	0						my ($x, $y) = $coord =~ /(\d\d)(\d\d)/;
366	0						foreach my $hex (@{$self->hexes}) {
	0
367	0	0	0				return $hex if $hex->x == $x and $hex->y == $y;
368							}
369							}
370
371							sub communications {
372							# connect all the class A starports, naval bases, and Imperial
373							# consulates
374	0			0	0		my ($self) = @_;
375	0	0					return if $self->comm_set;
376	0						my @candidates = ();
377	0						foreach my $hex (@{$self->hexes}) {
	0
378	0	0	0				push(@candidates, $hex)
			0
379							if $hex->starport eq 'A'
380							or $hex->naval
381							or $hex->consulate;
382							}
383							# every system has a link to its neighbours
384	0						foreach my $hex (@candidates) {
385	0						my @ar = nearby($hex, 2, \@candidates);
386	0						$hex->comm(\@ar);
387							}
388							# eliminate all but the best connections if the system has
389							# amber or red travel zone
390	0						foreach my $hex (@candidates) {
391	0	0					next unless $hex->travelzone;
392	0						my $best;
393	0						foreach my $other (@{$hex->comm}) {
	0
394	0	0	0				if (not $best
			0
			0
395							or $other->starport lt $best->starport
396							or $other->starport eq $best->starport
397							and distance($hex, $other) < distance($hex, $best)) {
398	0						$best = $other;
399							}
400							}
401	0						$hex->eliminate(grep { $_ != $best } @{$hex->comm});
	0
	0
402							}
403							}
404
405							sub trade {
406							# connect In or Ht with As, De, Ic, Ni
407							# connect Hi or Ri with Ag, Ga, Wa
408	0			0	0		my ($self) = @_;
409	0	0					return if $self->trade_set;
410							# candidates need to be on a travel route, i.e. must have fuel
411							# available; skip worlds with a red travel zone
412	0						my @candidates = ();
413	0						foreach my $hex (@{$self->hexes}) {
	0
414							push(@candidates, $hex)
415							if ($hex->starport =~ /^[A-D]$/
416							or $hex->gasgiant
417							or $hex->trade->{Wa})
418	0	0	0				and $hex->travelzone ne 'R';
			0
419							}
420							# every system has a link to its partners
421	0						foreach my $hex (@candidates) {
422	0						my @routes;
423	0	0	0				if ($hex->trade->{In} or $hex->trade->{Ht}) {
		0	0
424	0						foreach my $other (nearby($hex, 4, \@candidates)) {
425	0	0	0				if ($other->trade->{As}
			0
			0
426							or $other->trade->{De}
427							or $other->trade->{Ic}
428							or $other->trade->{Ni}) {
429	0						my @route = $self->route($hex, $other, 4, \@candidates);
430	0	0					push(@routes, \@route) if @route;
431							}
432							}
433							} elsif ($hex->trade->{Hi} or $hex->trade->{Ri}) {
434	0						foreach my $other (nearby($hex, 4, \@candidates)) {
435	0	0	0				if ($other->trade->{Ag}
			0
436							or $other->trade->{Ga}
437							or $other->trade->{Wa}) {
438	0						my @route = $self->route($hex, $other, 4, \@candidates);
439	0	0					push(@routes, \@route) if @route;
440							}
441							}
442							}
443	0						$hex->routes(\@routes);
444							}
445	0						$self->routes($self->minimal_spanning_tree($self->edges(@candidates)));
446							}
447
448							sub edges {
449	0			0	0		my $self = shift;
450	0						my @edges;
451							my %seen;
452	0						foreach my $hex (@_) {
453	0						foreach my $route (@{$hex->routes}) {
	0
454	0						my ($start, @route) = @{$route};
	0
455	0						foreach my $end (@route) {
456							# keep everything unidirectional
457	0	0	0				next if exists $seen{$start}{$end} or exists $seen{$end}{$start};
458	0						push(@edges, [$start, $end, distance($start,$end)]);
459	0						$seen{$start}{$end} = 1;
460	0						$start = $end;
461							}
462							}
463							}
464	0						return @edges;
465							}
466
467							sub minimal_spanning_tree {
468							# http://en.wikipedia.org/wiki/Kruskal%27s_algorithm
469	0			0	0		my $self = shift;
470							# Initialize a priority queue Q to contain all edges in G, using the
471							# weights as keys.
472	0						my @Q = sort { @{$a}[2] <=> @{$b}[2] } @_;
	0
	0
	0
473							# Define a forest T ← Ø; T will ultimately contain the edges of the MST
474	0						my @T;
475							# Define an elementary cluster C(v) ← {v}.
476							my %C;
477	0						my $id;
478	0						foreach my $edge (@Q) {
479							# edge u,v is the minimum weighted route from u to v
480	0						my ($u, $v) = @{$edge};
	0
481							# $u = $u->name;
482							# $v = $v->name;
483							# prevent cycles in T; add u,v only if T does not already contain
484							# a path between u and v; also silence warnings
485	0	0	0				if (not $C{$u} or not $C{$v} or $C{$u} != $C{$v}) {
			0
486							# Add edge (v,u) to T.
487	0						push(@T, $edge);
488							# Merge C(v) and C(u) into one cluster, that is, union C(v) and C(u).
489	0	0	0				if ($C{$u} and $C{$v}) {
		0	0
		0	0
		0	0
490	0						my @group;
491	0						foreach (keys %C) {
492	0	0					push(@group, $_) if $C{$_} == $C{$v};
493							}
494	0						$C{$_} = $C{$u} foreach @group;
495							} elsif ($C{$v} and not $C{$u}) {
496	0						$C{$u} = $C{$v};
497							} elsif ($C{$u} and not $C{$v}) {
498	0						$C{$v} = $C{$u};
499							} elsif (not $C{$u} and not $C{$v}) {
500	0						$C{$v} = $C{$u} = ++$id;
501							}
502							}
503							}
504	0						return \@T;
505							}
506
507							sub route {
508							# Compute the shortest route between two hexes no longer than a
509							# certain distance and choosing intermediary steps from the array of
510							# possible candidates.
511	0			0	0		my ($self, $from, $to, $distance, $candidatesref, @seen) = @_;
512							# my $indent = ' ' x (4-$distance);
513	0						my @options;
514	0	0					foreach my $hex (nearby($from, $distance < 2 ? $distance : 2, $candidatesref)) {
515	0	0					push (@options, $hex) unless in($hex, @seen);
516							}
517	0	0	0				return unless @options and $distance;
518	0	0					if (in($to, @options)) {
519	0						return @seen, $from, $to;
520							}
521	0						my @routes;
522	0						foreach my $hex (@options) {
523	0						my @route = $self->route($hex, $to, $distance - distance($from, $hex),
524							$candidatesref, @seen, $from);
525	0	0					if (@route) {
526	0						push(@routes, \@route);
527							}
528							}
529	0	0					return unless @routes;
530							# return the shortest one
531	0						my @shortest;
532	0						foreach my $route (@routes) {
533	0	0	0				if ($#{$route} < $#shortest or not @shortest) {
	0
534	0						@shortest = @{$route};
	0
535							}
536							}
537	0						return @shortest;
538							}
539
540							sub trade_svg {
541	0			0	0		my $self = shift;
542	0						my $data = '';
543	0						my $scale = 100;
544	0						foreach my $edge (@{$self->routes}) {
	0
545	0						my $u = @{$edge}[0];
	0
546	0						my $v = @{$edge}[1];
	0
547	0						my ($x1, $y1) = ($u->x, $u->y);
548	0						my ($x2, $y2) = ($v->x, $v->y);
549	0						$data .= sprintf(qq{ \n},
550							(1 + ($x1-1) * 1.5) * $scale, ($y1 - $x1%2/2) * sqrt(3) * $scale,
551							(1 + ($x2-1) * 1.5) * $scale, ($y2 - $x2%2/2) * sqrt(3) * $scale);
552							}
553	0						return $data;
554							}
555
556							sub svg {
557	0			0	0		my ($self, $width, $height) = @_;
558	0						my $data = $self->header($width, $height);
559	0						$data .= qq{ \n};
560	0						$data .= $self->background;
561	0						$data .= qq{ \n\n};
562	0						$data .= qq{ \n};
563	0						foreach my $hex (@{$self->hexes}) {
	0
564	0						$data .= $hex->comm_svg();
565							}
566	0						$data .= qq{ \n\n};
567	0						$data .= qq{ \n};
568	0						$data .= $self->trade_svg();
569	0						$data .= qq{ \n\n};
570	0						$data .= qq{ \n};
571	0						$data .= $self->grid;
572	0						$data .= qq{ \n\n};
573	0						$data .= qq{ \n};
574	0						$data .= $self->legend();
575	0						$data .= qq{ \n\n};
576	0						$data .= qq{ \n};
577	0						foreach my $hex (@{$self->hexes}) {
	0
578	0						$data .= $hex->system_svg();
579							}
580	0						$data .= qq{ \n};
581	0						$data .= $self->footer();
582	0						return $data;
583							}
584
585							sub text {
586	0			0	0		my ($self) = @_;
587	0						my $data = "Trade Routes:\n";
588	0						foreach my $edge (@{$self->routes}) {
	0
589	0						my $u = @{$edge}[0];
	0
590	0						my $v = @{$edge}[1];
	0
591	0						$data .= $u->name . " - " . $v->name . "\n";
592							}
593	0						$data .= "\n";
594	0						$data .= "Raw Data:\n";
595	0						foreach my $hex (@{$self->hexes}) {
	0
596	0						foreach my $routeref (@{$hex->routes}) {
	0
597	0						$data .= join(' - ', map {$_->name} @{$routeref}) . "\n";
	0
	0
598							}
599							}
600	0						$data .= "\n";
601	0						$data .= "Communications:\n";
602	0						foreach my $hex (@{$self->hexes}) {
	0
603	0						foreach my $comm (@{$hex->comm}) {
	0
604	0						$data .= $hex->name . " - " . $comm->name . "\n";;
605							}
606							}
607	0						return $data;
608							}
609
610							1;