App-traveller
view release on metacpan or search on metacpan
lib/Traveller/Mapper.pm view on Meta::CPAN
Raraxema 0609 B421768-8 T NSG Na Po
Xeerri 0610 C210862-9 G Na
Onreon 0702 D8838A9-2 S Lt Ri A
Ismave 0703 E272654-4 Lt Ni
Lara 0704 C0008D9-5 SG As Lt Na Va A
Lalala 0705 C140473-9 R G De Ni Po
Maxereis 0707 A55A747-12 CT NSG Ht Wa
Requbire 0802 C9B4200-10 G Fl Lo A
Azaxe 0804 B6746B9-8 C G Ag Ga Ni A
Rieddige 0805 B355578-7 G Ag Ni A
Usorce 0806 E736110-3 G Lo Lt A
Solacexe 0810 D342635-4 P S Lt Ni Po R
!;
sub example {
return $example;
}
# The empty hex is centered around 0,0 and has a side length of 1,
# a maximum diameter of 2, and a minimum diameter of √3.
my @hex = ( -1, 0,
-0.5, sqrt(3)/2,
0.5, sqrt(3)/2,
1, 0,
0.5, -sqrt(3)/2,
-0.5, -sqrt(3)/2);
sub header {
my ($self, $width, $height) = @_;
# TO DO: support an option for North American “A†paper dimensions (width 215.9 mm, length 279.4 mm)
$width //= 210;
$height //= 297;
my $template = <<EOT;
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<svg xmlns="http://www.w3.org/2000/svg" version="1.1"
xmlns:xlink="http://www.w3.org/1999/xlink"
width="${width}mm"
height="${height}mm"
viewBox="%s %s %s %s">
<desc>Traveller Subsector</desc>
<defs>
<style type="text/css"><![CDATA[
text {
font-size: 16pt;
font-family: Optima, "Optima Regular", Optima-Regular, Helvetica, sans-serif;
text-anchor: middle;
}
text a {
fill: blue;
text-decoration: underline;
}
.coordinates {
fill-opacity: 0.5;
}
.starport, .base {
font-size: 20pt;
}
.direction {
font-size: 24pt;
}
.legend {
text-anchor: start;
font-size: 14pt;
}
tspan.comm {
fill: #ff6347; /* tomato */
}
line.comm {
stroke-width: 10pt;
stroke: #ff6347; /* tomato */
}
tspan.trade {
fill: #afeeee; /* pale turquoise */
}
line.trade {
stroke-width: 6pt;
stroke: #afeeee; /* pale turquoise */
fill: none;
}
.travelzone {
opacity: 0.3;
}
.amber {
fill: none;
stroke-width: 1pt;
stroke: black;
}
.red {
fill: red;
}
#hex {
stroke-width: 3pt;
fill: none;
stroke: black;
}
#background {
fill: inherit;
}
#bg {
fill: inherit;
}
]]></style>
<polygon id="hex" points="%s,%s %s,%s %s,%s %s,%s %s,%s %s,%s" />
<polygon id="bg" points="%s,%s %s,%s %s,%s %s,%s %s,%s %s,%s" />
</defs>
<rect fill="white" stroke="black" stroke-width="10" id="frame"
x="%s" y="%s" width="%s" height="%s" />
EOT
my $scale = 100;
return sprintf($template,
map { sprintf("%.3f", $_ * $scale) }
# viewport
-0.5, -0.5, 3 + ($self->width - 1) * 1.5, ($self->height + 1.5) * sqrt(3),
# empty hex, once for the backgrounds and once for the stroke
@hex,
@hex,
# framing rectangle
-0.5, -0.5, 3 + ($self->width - 1) * 1.5, ($self->height + 1.5) * sqrt(3));
}
sub colour {
my $self = shift;
my $culture = shift or return "white";
# The same colours result from the same names.
my @colours = ("#d3d3d3", "#f5f5f5", "#eaeaea", "#fffeb0", "#fff0f5", "#eee0e5", "#ffe1ff",
"#eed2ee", "#c6e2ff", "#fdf5e6", "#e0ffff", "#d1eeee", "#c5fff5", "#eeeee0",
"#fff68f", "#eee685", "#fffacd", "#eee9bf", "#ffe7ba", "#ffefdb", "#ffe4e1",
"#eed5d2", "#e6e6fa", "#f0ffff", "#c5ffd5", "#e6ffe6", "#d5ffc5", "#f5f5dc");
my $i = unpack("%32W*", lc $culture) % @colours; # checksum
return $colours[$i];
}
sub background {
my $self = shift;
my $scale = 100;
return join("\n", map {
my $hex = $_;
my $x = $hex->x;
my $y = $hex->y;
my $c = $hex->colour || $self->colour($hex->culture);
sprintf(qq{ <use xlink:href="#bg" x="%.3f" y="%.3f" fill="$c"/>},
(1 + ($x-1) * 1.5) * $scale,
($y - $x%2/2) * sqrt(3) * $scale);
} @{$self->hexes});
}
sub grid {
my $self = shift;
my $scale = 100;
my $doc;
$doc .= join("\n",
map {
my $n = shift;
my $x = int($_/$self->height+1);
my $y = $_ % $self->height + 1;
my $svg = sprintf(qq{ <use xlink:href="#hex" x="%.3f" y="%.3f"/>\n},
(1 + ($x-1) * 1.5) * $scale,
($y - $x%2/2) * sqrt(3) * $scale);
$svg .= sprintf(qq{ <text class="coordinates" x="%.3f" y="%.3f">}
. qq{%02d%02d</text>\n},
(1 + ($x-1) * 1.5) * $scale,
($y - $x%2/2) * sqrt(3) * $scale - 0.6 * $scale,
$x, $y);
} (0 .. $self->width * $self->height - 1));
return $doc;
}
sub legend {
my $self = shift;
my $scale = 100;
my $doc;
my $uwp = '';
if ($self->source) {
$uwp = ' – <a xlink:href="' . $self->source . '">UWP</a>';
}
$doc .= sprintf(qq{ <text class="legend" x="%.3f" y="%.3f">â—‰ gas giant}
. qq{ – ■Imperial consulate – ☼ TAS facility – ▲ scout base}
. qq{ – ★ naval base – π research station – ☠pirate base}
. qq{ – <tspan class="comm">▮</tspan> communication}
. qq{ – <tspan class="trade">▮</tspan> trade$uwp</text>\n},
-10, ($self->height + 1) * sqrt(3) * $scale);
$doc .= sprintf(qq{ <text class="direction" x="%.3f" y="%.3f">coreward</text>\n},
$self->width/2 * 1.5 * $scale, -0.13 * $scale);
$doc .= sprintf(qq{ <text transform="translate(%.3f,%.3f) rotate(90)"}
. qq{ class="direction">trailing</text>\n},
($self->width + 0.4) * 1.5 * $scale, $self->height/2 * sqrt(3) * $scale);
$doc .= sprintf(qq{ <text class="direction" x="%.3f" y="%.3f">rimward</text>\n},
$self->width/2 * 1.5 * $scale, ($self->height + 0.7) * sqrt(3) * $scale);
$doc .= sprintf(qq{ <text transform="translate(%.3f,%.3f) rotate(-90)"}
. qq{ class="direction">spinward</text>\n},
-0.1 * $scale, $self->height/2 * sqrt(3) * $scale);
return $doc;
}
sub footer {
my $self = shift;
my $doc;
my $y = 10;
my $debug = ''; # for developers
for my $line (split(/\n/, $debug)) {
$doc .= qq{<text xml:space="preserve" class="legend" y="$y" stroke="red">}
. $line . qq{</text>\n};
$y += 20;
}
$doc .= qq{</svg>\n};
return $doc;
}
sub initialize {
my ($self, $map, $wiki, $source) = @_;
$self->source($source);
$self->width(0);
$self->height(0);
my @lines = split(/\n/, $map);
$self->initialize_map($wiki, \@lines);
$self->initialize_routes(\@lines);
}
sub initialize_map {
my ($self, $wiki, $lines) = @_;
foreach (@$lines) {
# parse Traveller UWP, with optional name
my ($name, $x, $y,
$starport, $size, $atmosphere, $hydrographic, $population,
$government, $law, $tech, $bases, $rest) =
/(?:([^>\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)?(.*)/;
# alternative super simple name, coordinates, optional size (0-9), optional bases (PCTRNSG), optional travel zones (AR)
($name, $x, $y, $size, $bases, $rest) =
/([^>\r\n\t]*?)\s+(\d\d)(\d\d)(?:\s+(\d)\b)?(?:\s+([PCTRNSG ]+)\b)?(.*)/
unless $x and $y;
next unless $x and $y;
$self->width($x) if $x > $self->width;
$self->height($y) if $y > $self->height;
my @tokens = split(' ', $rest);
my @colours = grep(/^$colour_re$/, @tokens);
my %trade = map { $_ => 1 } grep(/^[A-Z][A-Za-z]$/, @tokens);
my ($culture) = grep /^\[.*\]$/, @tokens; # culture in square brackets
my ($travelzone) = grep /^([AR])$/, @tokens; # amber or red travel zone
# avoid uninitialized values warnings in the rest of the code
map { $$_ //= '' } (\$size,
\$atmosphere,
\$hydrographic,
\$population,
\$government,
\$law,
\$starport,
\$travelzone);
# get "hex" values, but accept letters beyond F! (excepting I and O)
map { $$_ = $$_ ge 'P' and $$_ le 'Z' ? 23 + ord($$_) - 80
: $$_ ge 'J' and $$_ le 'N' ? 18 + ord($$_) - 74
: $$_ ge 'A' and $$_ le 'H' ? 10 + ord($$_) - 65
: $$_ eq '' ? 0
: $$_ } (\$size,
\$atmosphere,
\$hydrographic,
\$population,
\$government,
\$law);
my $hex = Traveller::Hex->new(
name => $name,
x => $x,
lib/Traveller/Mapper.pm view on Meta::CPAN
my @options;
foreach my $hex (nearby($from, $distance < 2 ? $distance : 2, $candidatesref)) {
push (@options, $hex) unless in($hex, @seen);
}
return unless @options and $distance;
if (in($to, @options)) {
return @seen, $from, $to;
}
my @routes;
foreach my $hex (@options) {
my @route = $self->route($hex, $to, $distance - distance($from, $hex),
$candidatesref, @seen, $from);
if (@route) {
push(@routes, \@route);
}
}
return unless @routes;
# return the shortest one
my @shortest;
foreach my $route (@routes) {
if ($#{$route} < $#shortest or not @shortest) {
@shortest = @{$route};
}
}
return @shortest;
}
sub trade_svg {
my $self = shift;
my $data = '';
my $scale = 100;
foreach my $edge (@{$self->routes}) {
my $u = @{$edge}[0];
my $v = @{$edge}[1];
my ($x1, $y1) = ($u->x, $u->y);
my ($x2, $y2) = ($v->x, $v->y);
$data .= sprintf(qq{ <line class="trade" x1="%.3f" y1="%.3f" x2="%.3f" y2="%.3f" />\n},
(1 + ($x1-1) * 1.5) * $scale, ($y1 - $x1%2/2) * sqrt(3) * $scale,
(1 + ($x2-1) * 1.5) * $scale, ($y2 - $x2%2/2) * sqrt(3) * $scale);
}
return $data;
}
sub svg {
my ($self, $width, $height) = @_;
my $data = $self->header($width, $height);
$data .= qq{ <g id='background'>\n};
$data .= $self->background;
$data .= qq{ </g>\n\n};
$data .= qq{ <g id='comm'>\n};
foreach my $hex (@{$self->hexes}) {
$data .= $hex->comm_svg();
}
$data .= qq{ </g>\n\n};
$data .= qq{ <g id='routes'>\n};
$data .= $self->trade_svg();
$data .= qq{ </g>\n\n};
$data .= qq{ <g id='grid'>\n};
$data .= $self->grid;
$data .= qq{ </g>\n\n};
$data .= qq{ <g id='legend'>\n};
$data .= $self->legend();
$data .= qq{ </g>\n\n};
$data .= qq{ <g id='system'>\n};
foreach my $hex (@{$self->hexes}) {
$data .= $hex->system_svg();
}
$data .= qq{ </g>\n};
$data .= $self->footer();
return $data;
}
sub text {
my ($self) = @_;
my $data = "Trade Routes:\n";
foreach my $edge (@{$self->routes}) {
my $u = @{$edge}[0];
my $v = @{$edge}[1];
$data .= $u->name . " - " . $v->name . "\n";
}
$data .= "\n";
$data .= "Raw Data:\n";
foreach my $hex (@{$self->hexes}) {
foreach my $routeref (@{$hex->routes}) {
$data .= join(' - ', map {$_->name} @{$routeref}) . "\n";
}
}
$data .= "\n";
$data .= "Communications:\n";
foreach my $hex (@{$self->hexes}) {
foreach my $comm (@{$hex->comm}) {
$data .= $hex->name . " - " . $comm->name . "\n";;
}
}
return $data;
}
1;
( run in 0.588 second using v1.01-cache-2.11-cpan-df04353d9ac )