line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/bin/perl |
2
|
|
|
|
|
|
|
# Copyright (C) 2009-2021 Alex Schroeder |
3
|
|
|
|
|
|
|
# Copyright (C) 2020 Christian Carey |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# This program is free software: you can redistribute it and/or modify it under |
6
|
|
|
|
|
|
|
# the terms of the GNU General Public License as published by the Free Software |
7
|
|
|
|
|
|
|
# Foundation, either version 3 of the License, or (at your option) any later |
8
|
|
|
|
|
|
|
# version. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# This program is distributed in the hope that it will be useful, but WITHOUT |
11
|
|
|
|
|
|
|
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS |
12
|
|
|
|
|
|
|
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
13
|
|
|
|
|
|
|
# |
14
|
|
|
|
|
|
|
# You should have received a copy of the GNU General Public License along with |
15
|
|
|
|
|
|
|
# this program. If not, see . |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
package Traveller::Hex; |
18
|
2
|
|
|
2
|
|
15
|
use Mojo::Base -base; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
21
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
has 'name'; |
21
|
|
|
|
|
|
|
has 'x'; |
22
|
|
|
|
|
|
|
has 'y'; |
23
|
|
|
|
|
|
|
has 'starport'; |
24
|
|
|
|
|
|
|
has 'size'; |
25
|
|
|
|
|
|
|
has 'population'; |
26
|
|
|
|
|
|
|
has 'consulate'; |
27
|
|
|
|
|
|
|
has 'pirate'; |
28
|
|
|
|
|
|
|
has 'TAS'; |
29
|
|
|
|
|
|
|
has 'research'; |
30
|
|
|
|
|
|
|
has 'naval'; |
31
|
|
|
|
|
|
|
has 'scout'; |
32
|
|
|
|
|
|
|
has 'gasgiant'; |
33
|
|
|
|
|
|
|
has 'travelzone'; |
34
|
|
|
|
|
|
|
has 'url'; |
35
|
|
|
|
|
|
|
has 'map'; |
36
|
|
|
|
|
|
|
has 'comm' => sub { [] }; |
37
|
|
|
|
|
|
|
has 'trade' => sub { {} }; |
38
|
|
|
|
|
|
|
has 'routes' => sub { [] }; |
39
|
|
|
|
|
|
|
has 'culture'; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
sub base { |
42
|
0
|
|
|
0
|
0
|
|
my ($self, $key) = @_; |
43
|
0
|
|
|
|
|
|
$key = uc($key); |
44
|
0
|
0
|
|
|
|
|
($key eq 'C') ? $self->consulate(1) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
45
|
|
|
|
|
|
|
: ($key eq 'P') ? $self->pirate(1) |
46
|
|
|
|
|
|
|
: ($key eq 'T') ? $self->TAS(1) |
47
|
|
|
|
|
|
|
: ($key eq 'R') ? $self->research(1) |
48
|
|
|
|
|
|
|
: ($key eq 'N') ? $self->naval(1) |
49
|
|
|
|
|
|
|
: ($key eq 'S') ? $self->scout(1) |
50
|
|
|
|
|
|
|
: ($key eq 'G') ? $self->gasgiant(1) |
51
|
|
|
|
|
|
|
: undef; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub at { |
55
|
0
|
|
|
0
|
0
|
|
my ($self, $x, $y) = @_; |
56
|
0
|
|
0
|
|
|
|
return $self->x == $x && $self->y == $y; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub str { |
60
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
61
|
0
|
|
|
|
|
|
sprintf "%-12s %02s%02s ", $self->name, $self->x, $self->y; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
sub eliminate { |
65
|
0
|
|
|
0
|
0
|
|
my $from = shift; |
66
|
0
|
|
|
|
|
|
foreach my $to (@_) { |
67
|
|
|
|
|
|
|
# eliminate the communication $from -> $to |
68
|
0
|
|
|
|
|
|
my @ar1 = grep {$_ != $to} @{$from->comm}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
69
|
0
|
|
|
|
|
|
$from->comm(\@ar1); |
70
|
|
|
|
|
|
|
# eliminate the communication $to -> $from |
71
|
0
|
|
|
|
|
|
my @ar2 = grep {$_ != $from} @{$to->comm}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
72
|
0
|
|
|
|
|
|
$to->comm(\@ar2); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub comm_svg { |
77
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
78
|
0
|
|
|
|
|
|
my $data = ''; |
79
|
0
|
|
|
|
|
|
my $scale = 100; |
80
|
0
|
|
|
|
|
|
my ($x1, $y1) = ($self->x, $self->y); |
81
|
0
|
|
|
|
|
|
foreach my $to (@{$self->comm}) { |
|
0
|
|
|
|
|
|
|
82
|
0
|
|
|
|
|
|
my ($x2, $y2) = ($to->x, $to->y); |
83
|
0
|
|
|
|
|
|
$data .= sprintf(qq{ \n}, |
84
|
|
|
|
|
|
|
(1 + ($x1-1) * 1.5) * $scale, ($y1 - $x1%2/2) * sqrt(3) * $scale, |
85
|
|
|
|
|
|
|
(1 + ($x2-1) * 1.5) * $scale, ($y2 - $x2%2/2) * sqrt(3) * $scale); |
86
|
|
|
|
|
|
|
} |
87
|
0
|
|
|
|
|
|
return $data; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# The empty hex is centered around 0,0 and has a side length of 1, a |
91
|
|
|
|
|
|
|
# maximum diameter of 2, and a minimum diameter of √3. The subsector |
92
|
|
|
|
|
|
|
# is 10 hexes high and eight hexes wide. The 0101 corner is at the top |
93
|
|
|
|
|
|
|
# left. |
94
|
|
|
|
|
|
|
sub system_svg { |
95
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
96
|
0
|
|
|
|
|
|
my $x = $self->x; |
97
|
0
|
|
|
|
|
|
my $y = $self->y; |
98
|
0
|
|
|
|
|
|
my $name = $self->name; |
99
|
0
|
0
|
|
|
|
|
my $display = ($self->population >= 9 ? uc($name) : $name); |
100
|
0
|
|
|
|
|
|
my $starport = $self->starport; |
101
|
0
|
|
|
|
|
|
my $size = $self->size; |
102
|
0
|
|
|
|
|
|
my $url = $self->url; |
103
|
0
|
0
|
|
|
|
|
my $lead = ($url ? ' ' : ''); |
104
|
0
|
|
|
|
|
|
my $data = ''; |
105
|
0
|
0
|
|
|
|
|
$data .= qq{ \n} if $url; |
106
|
0
|
|
|
|
|
|
$data .= qq{$lead \n}; |
107
|
0
|
|
|
|
|
|
my $scale = 100; |
108
|
|
|
|
|
|
|
# travel zone red painted first, so it appears at the bottom |
109
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead \n}, |
110
|
|
|
|
|
|
|
(1 + ($x-1) * 1.5) * $scale, |
111
|
|
|
|
|
|
|
($y - $x%2/2) * sqrt(3) * $scale, 0.52 * $scale) |
112
|
|
|
|
|
|
|
if $self->travelzone eq 'R'; |
113
|
0
|
|
|
|
|
|
$data .= sprintf(qq{$lead \n}, |
114
|
|
|
|
|
|
|
(1 + ($x-1) * 1.5) * $scale, |
115
|
|
|
|
|
|
|
($y - $x%2/2) * sqrt(3) * $scale, 11 + $size); |
116
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead \n}, |
117
|
|
|
|
|
|
|
(1 + ($x-1) * 1.5) * $scale, |
118
|
|
|
|
|
|
|
($y - $x%2/2) * sqrt(3) * $scale, 0.52 * $scale) |
119
|
|
|
|
|
|
|
if $self->travelzone eq 'A'; |
120
|
0
|
|
|
|
|
|
$data .= sprintf(qq{$lead $starport\n}, |
121
|
|
|
|
|
|
|
(1 + ($x-1) * 1.5) * $scale, |
122
|
|
|
|
|
|
|
($y - $x%2/2 - 0.17) * sqrt(3) * $scale); |
123
|
0
|
|
|
|
|
|
$data .= sprintf(qq{$lead $display\n}, |
124
|
|
|
|
|
|
|
(1 + ($x-1) * 1.5) * $scale, |
125
|
|
|
|
|
|
|
($y - $x%2/2 + 0.4) * sqrt(3) * $scale); |
126
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead ■\n}, |
127
|
|
|
|
|
|
|
(0.6 + ($x-1) * 1.5) * $scale, |
128
|
|
|
|
|
|
|
($y - $x%2/2 + 0.25) * sqrt(3) * $scale) |
129
|
|
|
|
|
|
|
if $self->consulate; |
130
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead ☼\n}, |
131
|
|
|
|
|
|
|
(0.4 + ($x-1) * 1.5) * $scale, |
132
|
|
|
|
|
|
|
($y - $x%2/2 + 0.1) * sqrt(3) * $scale) |
133
|
|
|
|
|
|
|
if $self->TAS; |
134
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead ▲\n}, |
135
|
|
|
|
|
|
|
(0.4 + ($x-1) * 1.5) * $scale, |
136
|
|
|
|
|
|
|
($y - $x%2/2 - 0.1) * sqrt(3) * $scale) |
137
|
|
|
|
|
|
|
if $self->scout; |
138
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead ★\n}, |
139
|
|
|
|
|
|
|
(0.6 + ($x-1) * 1.5) * $scale, |
140
|
|
|
|
|
|
|
($y - $x%2/2 - 0.25) * sqrt(3) * $scale) |
141
|
|
|
|
|
|
|
if $self->naval; |
142
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead ◉\n}, |
143
|
|
|
|
|
|
|
(1.4 + ($x-1) * 1.5) * $scale, |
144
|
|
|
|
|
|
|
($y - $x%2/2 - 0.25) * sqrt(3) * $scale) |
145
|
|
|
|
|
|
|
if $self->gasgiant; |
146
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead π\n}, |
147
|
|
|
|
|
|
|
(1.6 + ($x-1) * 1.5) * $scale, |
148
|
|
|
|
|
|
|
($y - $x%2/2 - 0.1) * sqrt(3) * $scale) |
149
|
|
|
|
|
|
|
if $self->research; |
150
|
0
|
0
|
|
|
|
|
$data .= sprintf(qq{$lead ☠\n}, |
151
|
|
|
|
|
|
|
(1.6 + ($x-1) * 1.5) * $scale, |
152
|
|
|
|
|
|
|
($y - $x%2/2 + 0.1) * sqrt(3) * $scale) |
153
|
|
|
|
|
|
|
if $self->pirate; |
154
|
|
|
|
|
|
|
# last slot unused |
155
|
0
|
|
|
|
|
|
$data .= qq{$lead \n}; |
156
|
0
|
0
|
|
|
|
|
$data .= qq{ \n} if $url; |
157
|
0
|
|
|
|
|
|
return $data; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
1; |