File Coverage

blib/lib/Traveller/Mapper.pm

Criterion	Covered	Total	%
statement	13	284	4.5
branch	0	88	0.0
condition	0	88	0.0
subroutine	5	23	21.7
pod	0	19	0.0
total	18	502	3.5

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