File Coverage

blib/lib/Traveller/System.pm
Criterion Covered Total %
statement 193 193 100.0
branch 161 166 96.9
condition 176 186 94.6
subroutine 21 21 100.0
pod 0 17 0.0
total 551 583 94.5


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::System;
18 2     2   1167 use Mojo::Base -base;
  2         5  
  2         20  
19 2     2   353 use List::Util qw(any);
  2         5  
  2         4980  
20              
21             has 'name';
22             has 'x';
23             has 'y';
24             has 'starport';
25             has 'size';
26             has 'atmosphere';
27             has 'temperature';
28             has 'hydro';
29             has 'population';
30             has 'government';
31             has 'law';
32             has 'tech';
33             has 'consulate';
34             has 'pirate';
35             has 'TAS';
36             has 'research';
37             has 'naval';
38             has 'scout';
39             has 'gasgiant';
40             has 'tradecodes';
41             has 'travelzone';
42             has 'culture';
43              
44             sub compute_name {
45 1328     1328 0 1849 my $self = shift;
46 1328         1808 my $digraphs = shift;
47 1328         2051 my $max = scalar(@$digraphs);
48 1328         2094 my $length = 3 + rand(3); # length of name before adding one more
49 1328         2369 my $name = '';
50 1328         3014 while (length($name) < $length) {
51 3078         5027 my $i = 2*int(rand($max/2));
52 3078         4768 $name .= $digraphs->[$i];
53 3078         6257 $name .= $digraphs->[$i+1];
54             }
55 1328         2881 $name =~ s/\.//g;
56 1328         4435 return ucfirst($name);
57             }
58              
59             sub roll1d6 {
60 18215     18215 0 41790 return 1+int(rand(6));
61             }
62              
63             sub roll2d6 {
64 8761     8761 0 11256 my $self = shift;
65 8761         12499 return $self->roll1d6() + $self->roll1d6();
66             }
67              
68             sub compute_starport {
69 693     693 0 1138 my $self = shift;
70 693         5263 my %map = ( 2=>'X', 3=>'E', 4=>'E', 5=>'D', 6=>'D', 7=>'C',
71             8=>'C', 9=>'B', 10=>'B', 11=>'A', 12=>'A' );
72 693         1563 return $map{$self->roll2d6()};
73             }
74              
75             sub compute_bases {
76 693     693 0 1029 my $self = shift;
77 693 100       1345 if ($self->starport eq 'A') {
    100          
    100          
    100          
    100          
78 62         364 $self->naval($self->roll2d6() >= 8);
79 62         425 $self->scout($self->roll2d6() >= 10);
80 62         371 $self->research($self->roll2d6() >= 8);
81 62         370 $self->TAS($self->roll2d6() >= 4);
82 62         459 $self->consulate($self->roll2d6() >= 6);
83             } elsif ($self->starport eq 'B') {
84 120         923 $self->naval($self->roll2d6() >= 8);
85 120         852 $self->scout($self->roll2d6() >= 8);
86 120         738 $self->research($self->roll2d6() >= 10);
87 120         741 $self->TAS($self->roll2d6() >= 6);
88 120         939 $self->consulate($self->roll2d6() >= 8);
89 120         740 $self->pirate($self->roll2d6() >= 12);
90             } elsif ($self->starport eq 'C') {
91 214         2299 $self->scout($self->roll2d6() >= 8);
92 214         1282 $self->research($self->roll2d6() >= 10);
93 214         1277 $self->TAS($self->roll2d6() >= 10);
94 214         1399 $self->consulate($self->roll2d6() >= 10);
95 214         1525 $self->pirate($self->roll2d6() >= 10);
96             } elsif ($self->starport eq 'D') {
97 156         1970 $self->scout($self->roll2d6() >= 7);
98 156         1048 $self->pirate($self->roll2d6() >= 12);
99             } elsif ($self->starport eq 'E') {
100 112         1871 $self->pirate($self->roll2d6() >= 12);
101             }
102 693         4438 $self->gasgiant($self->roll2d6() < 10);
103             }
104              
105             sub compute_atmosphere {
106 693     693 0 1017 my $self = shift;
107 693         1205 my $atmosphere = $self->roll2d6() -7 + $self->size;
108 693 100       2797 $atmosphere = 0 if $atmosphere < 0;
109 693         1830 return $atmosphere;
110             }
111              
112             sub compute_temperature {
113 693     693 0 1008 my $self = shift;
114 693         1154 my $temperature = $self->roll2d6();
115 693         1241 my $atmosphere = $self->atmosphere;
116 693 100 100     3770 $temperature -= 2
117             if $atmosphere == 2
118             or $atmosphere == 3;
119 693 100 100     2627 $temperature -= 1
      66        
120             if $atmosphere == 3
121             or $atmosphere == 4
122             or $atmosphere == 14; # E
123 693 100 100     2096 $temperature += 1
124             if $atmosphere == 8
125             or $atmosphere == 9;
126 693 100 100     2517 $temperature += 2
      66        
127             if $atmosphere == 10 # A
128             or $atmosphere == 13 # D
129             or $atmosphere == 15; # F
130 693 100 100     1967 $temperature += 6
131             if $atmosphere == 11 # B
132             or $atmosphere == 12; # C
133 693         1837 return $temperature;
134             }
135              
136             sub compute_hydro {
137 693     693 0 1017 my $self = shift;
138 693         1119 my $hydro = $self->roll2d6() - 7 + $self->size;
139 693 100 100     2597 $hydro -= 4
      100        
      100        
      100        
140             if $self->atmosphere == 0
141             or $self->atmosphere == 1
142             or $self->atmosphere == 10 # A
143             or $self->atmosphere == 11 # B
144             or $self->atmosphere == 12; # C
145 693 100 100     10639 $hydro -= 2
      100        
146             if $self->atmosphere != 13 # D
147             and $self->temperature >= 10
148             and $self->temperature <= 11;
149 693 100 100     5693 $hydro -= 6
150             if $self->atmosphere != 13 # D
151             and $self->temperature >= 12;
152 693 100 100     5441 $hydro = 0
153             if $self->size <= 1
154             or $hydro < 0;
155 693 100       3734 $hydro = 10 if $hydro > 10;
156 693         1735 return $hydro;
157             }
158              
159             sub compute_government {
160 693     693 0 1039 my $self = shift;
161 693         1224 my $government = $self->roll2d6() - 7 + $self->population; # max 15
162 693 100 100     3097 $government = 0
163             if $government < 0
164             or $self->population == 0;
165 693         3683 return $government;
166             }
167              
168             sub compute_law {
169 693     693 0 1039 my $self = shift;
170 693         1176 my $law = $self->roll2d6()-7+$self->government; # max 20!
171 693 100 100     3046 $law = 0
172             if $law < 0
173             or $self->population == 0;
174 693         3584 return $law;
175             }
176              
177             sub compute_tech {
178 693     693 0 1010 my $self = shift;
179 693         1080 my $tech = $self->roll1d6();
180 693 100       1304 $tech += 6 if $self->starport eq 'A';
181 693 100       3178 $tech += 4 if $self->starport eq 'B';
182 693 100       2821 $tech += 2 if $self->starport eq 'C';
183 693 100       3044 $tech -= 4 if $self->starport eq 'X';
184 693 100       2931 $tech += 2 if $self->size <= 1;
185 693 100 100     2738 $tech += 1 if $self->size >= 2 and $self->size <= 4;
186 693 100 100     5137 $tech += 1 if $self->atmosphere <= 3 or $self->atmosphere >= 10;
187 693 100 100     4263 $tech += 1 if $self->hydro == 0 or $self->hydro == 9;
188 693 100       4721 $tech += 2 if $self->hydro == 10;
189 693 100 100     2773 $tech += 1 if $self->population >= 1 and $self->population <= 5;
190 693 100       5044 $tech += 1 if $self->population == 9;
191 693 100       2663 $tech += 2 if $self->population == 10;
192 693 50       2644 $tech += 3 if $self->population == 11; # impossible?
193 693 50       2563 $tech += 4 if $self->population == 12; # impossible?
194 693 100 100     2753 $tech += 1 if $self->government == 0 or $self->government == 5;
195 693 100       4784 $tech += 2 if $self->government == 7;
196 693 100 100     2676 $tech -= 2 if $self->government == 13 or $self->government == 14;
197 693 100       4908 $tech = 0 if $self->population == 0;
198 693 100       2683 $tech = 15 if $tech > 15;
199 693         1861 return $tech;
200             }
201              
202             sub check_doom {
203 693     693 0 1026 my $self = shift;
204 693         928 my $doomed = 0;
205 693 100 100     1261 $doomed = 1 if $self->atmosphere <= 1 and $self->tech < 8;
206 693 100 100     3358 $doomed = 1 if $self->atmosphere <= 3 and $self->tech < 5;
207 693 100 100     3600 $doomed = 1 if ($self->atmosphere == 4
      100        
208             or $self->atmosphere == 7
209             or $self->atmosphere == 9) and $self->tech < 3;
210 693 100 100     7622 $doomed = 1 if $self->atmosphere == 10 and $self->tech < 8;
211 693 100 100     3087 $doomed = 1 if $self->atmosphere == 11 and $self->tech < 9;
212 693 100 100     2847 $doomed = 1 if $self->atmosphere == 12 and $self->tech < 10;
213 693 50 66     2777 $doomed = 1 if ($self->atmosphere == 13
      33        
214             and $self->atmosphere == 14) and $self->tech < 5;
215 693 50 33     2842 $doomed = 1 if $self->atmosphere == 15 and $self->tech < 8;
216 693 100       2942 if ($doomed) {
217 95         248 $self->population(0);
218 95         564 $self->government(0);
219 95         537 $self->law(0);
220 95         495 $self->tech(0);
221             }
222             }
223              
224             sub compute_tradecodes {
225 693     693 0 1011 my $self = shift;
226 693         964 my $tradecodes = '';
227 693 100 100     1302 $tradecodes .= " Ag" if $self->atmosphere >= 4 and $self->atmosphere <= 9
      100        
      100        
      100        
      100        
228             and $self->hydro >= 4 and $self->hydro <= 8
229             and $self->population >= 5 and $self->population <= 7;
230 693 100 100     8150 $tradecodes .= " As" if $self->size == 0 and $self->atmosphere == 0 and $self->hydro == 0;
      66        
231 693 50 66     3086 $tradecodes .= " Ba" if $self->population == 0 and $self->government == 0 and $self->law == 0;
      66        
232 693 100 100     3513 $tradecodes .= " De" if $self->atmosphere >= 2 and $self->hydro == 0;
233 693 100 100     4734 $tradecodes .= " Fl" if $self->atmosphere >= 10 and $self->hydro >= 1;
234 693 100 100     3085 $tradecodes .= " Ga" if $self->size >= 5
      100        
      100        
      100        
235             and $self->atmosphere >= 4 and $self->atmosphere <= 9
236             and $self->hydro >= 4 and $self->hydro <= 8;
237 693 100       7332 $tradecodes .= " Hi" if $self->population >= 9;
238 693 100       2878 $tradecodes .= " Ht" if $self->tech >= 12;
239 693 100 100     2753 $tradecodes .= " Ic" if $self->atmosphere <= 1 and $self->hydro >= 1;
240 693 100 100 221   3190 $tradecodes .= " In" if $self->population >= 9 and any { $_ == $self->atmosphere } qw(0 1 2 4 7 9);
  221         1235  
241 693 100 100     3011 $tradecodes .= " Lo" if $self->population >= 1 and $self->population <= 3;
242 693 100 100     4827 $tradecodes .= " Lt" if $self->tech >= 1 and $self->tech <= 5;
243 693 100 100     4551 $tradecodes .= " Na" if $self->atmosphere <= 3 and $self->hydro <= 3 and $self->population >= 6;
      100        
244 693 100 100     4330 $tradecodes .= " Ni" if $self->population >= 4 and $self->population <= 6;
245 693 100 100     4243 $tradecodes .= " Po" if $self->atmosphere >= 2 and $self->atmosphere <= 5 and $self->hydro <= 3;
      100        
246 693 100 100 366   5750 $tradecodes .= " Ri" if $self->population >= 6 and $self->population <= 8 and any { $_ == $self->atmosphere } qw(6 8);
  366   100     3963  
247 693 100       3662 $tradecodes .= " Wa" if $self->hydro >= 10;
248 693 100       2739 $tradecodes .= " Va" if $self->atmosphere == 0;
249 693         3921 return $tradecodes;
250             }
251              
252             sub compute_travelzone {
253 693     693 0 966 my $self = shift;
254 693         1025 my $danger = 0;
255 693 100       1326 $danger++ if $self->atmosphere >= 10;
256 693 100 100     3015 $danger++ if $self->population and $self->government == 0;
257 693 100       4741 $danger++ if $self->government == 7;
258 693 100       2636 $danger++ if $self->government == 10;
259 693 100 100     2595 $danger++ if $self->population and $self->law == 0;
260 693 100       4984 $danger++ if $self->law >= 9;
261 693 100 100     3066 return 'R' if $danger and $self->pirate;
262 672 100       3242 return 'A' if $danger;
263             }
264              
265             sub init {
266 693     693 0 1097 my $self = shift;
267 693         2226 $self->x(shift);
268 693         4529 $self->y(shift);
269 693         3768 $self->name($self->compute_name(shift));
270 693         4359 $self->starport($self->compute_starport);
271 693         4128 $self->compute_bases;
272 693         4115 $self->size($self->roll2d6()-2);
273 693         4097 $self->atmosphere($self->compute_atmosphere);
274 693         3945 $self->temperature($self->compute_temperature);
275 693         3828 $self->hydro($self->compute_hydro);
276 693         3741 $self->population($self->roll2d6()-2); # How to get to B and C in the table?
277 693         3959 $self->government($self->compute_government);
278 693         4334 $self->law($self->compute_law);
279 693         3720 $self->tech($self->compute_tech);
280 693         4045 $self->check_doom;
281 693         1685 $self->tradecodes($self->compute_tradecodes);
282 693         4502 $self->travelzone($self->compute_travelzone);
283 693         4780 return $self;
284             }
285              
286             sub code {
287 4158     4158 0 12826 my $num = shift;
288 4158 100       8133 return $num if $num < 10;
289 290         568 return chr(65-10+$num);
290             }
291              
292             sub str {
293 693     693 0 917 my $self = shift;
294 693         1196 my $uwp = sprintf("%-16s %02d%02d ", $self->name, $self->x, $self->y);
295 693         5973 $uwp .= $self->starport;
296 693         2925 $uwp .= code($self->size);
297 693         1406 $uwp .= code($self->atmosphere);
298 693         1320 $uwp .= code($self->hydro);
299 693         1342 $uwp .= code($self->population);
300 693         1245 $uwp .= code($self->government);
301 693         1357 $uwp .= code($self->law);
302 693         1051 $uwp .= '-';
303 693         1234 $uwp .= sprintf("%-2d", $self->tech);
304 693         2612 my $bases = '';
305 693 100       1215 $bases .= 'N' if $self->naval;
306 693 100       2780 $bases .= 'S' if $self->scout;
307 693 100       2803 $bases .= 'R' if $self->research;
308 693 100       2700 $bases .= 'T' if $self->TAS;
309 693 100       3168 $bases .= 'C' if $self->consulate;
310 693 100       2752 $bases .= 'P' if $self->pirate;
311 693 100       2732 $bases .= 'G' if $self->gasgiant;
312 693         3002 $uwp .= sprintf("%7s", $bases);
313 693         1280 $uwp .= ' ' . $self->tradecodes;
314 693 100       2763 $uwp .= ' ' . $self->travelzone if $self->travelzone;
315 693 100       3440 if ($self->culture) {
316 423         1706 my $spaces = 20 - length($self->tradecodes);
317 423 100       1539 $spaces -= 1 + length($self->travelzone) if $self->travelzone;
318 423         2102 $uwp .= ' ' x $spaces;
319 423         763 $uwp .= '[' . $self->culture . ']';
320             }
321 693         3409 return $uwp;
322             }
323              
324             1;