File Coverage

blib/lib/Traveller/Hex.pm
Criterion Covered Total %
statement 3 57 5.2
branch 0 40 0.0
condition 0 3 0.0
subroutine 1 7 14.2
pod 0 6 0.0
total 4 113 3.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::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;