File Coverage

blib/lib/Game/TileMap.pm
Criterion Covered Total %
statement 91 91 100.0
branch 8 12 66.6
condition 3 6 50.0
subroutine 16 16 100.0
pod 5 6 83.3
total 123 131 93.8


line stmt bran cond sub pod time code
1             package Game::TileMap;
2             $Game::TileMap::VERSION = '0.002';
3 2     2   138915 use v5.10;
  2         17  
4 2     2   10 use strict;
  2         26  
  2         57  
5 2     2   11 use warnings;
  2         5  
  2         74  
6              
7 2     2   1249 use Moo;
  2         23287  
  2         10  
8 2     2   3879 use Mooish::AttributeBuilder -standard;
  2         3543  
  2         14  
9 2     2   1517 use Storable qw(dclone);
  2         6651  
  2         134  
10 2     2   15 use Carp qw(croak);
  2         3  
  2         92  
11              
12 2     2   1023 use Game::TileMap::Legend;
  2         7  
  2         71  
13 2     2   887 use Game::TileMap::Tile;
  2         5  
  2         64  
14 2     2   854 use Game::TileMap::_Utils;
  2         5  
  2         1988  
15              
16             has param 'legend' => (
17              
18             # isa => InstanceOf ['Game::TileMap::Legend'],
19             );
20              
21             has field 'coordinates' => (
22             writer => -hidden,
23              
24             # isa => ArrayRef [ArrayRef [Any]],
25             );
26              
27             has field 'size_x' => (
28             writer => -hidden,
29              
30             # isa => PositiveInt,
31             );
32              
33             has field 'size_y' => (
34             writer => -hidden,
35              
36             # isa => PositiveInt,
37             );
38              
39             has field '_guide' => (
40             writer => 1,
41              
42             # isa => HashRef [ArrayRef [Tuple [Any, PositiveInt, PositiveInt]]],
43             );
44              
45             with qw(
46             Game::TileMap::Role::Checks
47             Game::TileMap::Role::Helpers
48             );
49              
50             sub new_legend
51             {
52 2     2 1 184 my $self = shift;
53              
54 2         23 return Game::TileMap::Legend->new(@_);
55             }
56              
57             sub BUILD
58             {
59 2     2 0 4536 my ($self, $args) = @_;
60              
61 2 50       33 if ($args->{map}) {
62             $self->from_string($args->{map})
63 2 50       22 if !ref $args->{map};
64              
65             $self->from_array($args->{map})
66 2 50       32 if ref $args->{map} eq 'ARRAY';
67             }
68             }
69              
70             sub from_string
71             {
72 2     2 1 6 my ($self, $map_str) = @_;
73 2         11 my $per_tile = $self->legend->characters_per_tile;
74              
75             my @map_lines =
76             reverse
77 20         76 grep { /\S/ }
78 2         12 map { Game::TileMap::_Utils::trim $_ }
  20         42  
79             split "\n", $map_str
80             ;
81              
82 2         5 my @map;
83 2         7 foreach my $line (@map_lines) {
84 20         27 my @objects;
85 20         35 while (length $line) {
86 182         305 my $marker = substr $line, 0, $per_tile, '';
87 182   33     490 push @objects, ($self->legend->objects->{$marker} // croak "Invalid map marker '$marker'");
88             }
89              
90 20         39 push @map, \@objects;
91             }
92              
93 2         16 return $self->from_array(\@map);
94             }
95              
96             sub from_array
97             {
98 2     2 1 8 my ($self, $map_aref) = @_;
99 2         4 my @map = @{$map_aref};
  2         7  
100              
101 2         6 my @map_size = (scalar @{$map[0]}, scalar @map);
  2         6  
102 2         5 my %guide;
103              
104             my @new_map;
105 2         9 foreach my $line (0 .. $#map) {
106             croak "invalid map size on line $line"
107 20 50       170 if @{$map[$line]} != $map_size[0];
  20         52  
108              
109 20         28 for my $col (0 .. $#{$map[$line]}) {
  20         53  
110 182         1455 my $prev_obj = $map[$line][$col];
111 182         2783 my $obj = Game::TileMap::Tile->new(contents => $prev_obj, x => $col, y => $line);
112              
113 182         880 $new_map[$col][$line] = $obj;
114 182         252 push @{$guide{$self->legend->get_class_of_object($prev_obj)}}, $obj;
  182         484  
115             }
116             }
117              
118 2         26 $self->_set_coordinates(\@new_map);
119 2         18 $self->_set_size_x($map_size[0]);
120 2         8 $self->_set_size_y($map_size[1]);
121 2         9 $self->_set_guide(\%guide);
122              
123 2         10 return $self;
124             }
125              
126             sub to_string
127             {
128 2     2 1 11008 return shift->to_string_and_mark;
129             }
130              
131             sub to_string_and_mark
132             {
133 5     5 1 14 my ($self, $mark_positions, $with) = @_;
134 5   66     42 $with //= '@' x $self->legend->characters_per_tile;
135              
136 5         8 my @lines;
137             my %markers_rev = map {
138 45         114 $self->legend->objects->{$_} => $_
139 5         11 } keys %{$self->legend->objects};
  5         33  
140              
141 5         17 my $mark = \undef;
142 5         13 my $coordinates = $self->coordinates;
143 5 100       16 if ($mark_positions) {
144 3         1217 $coordinates = dclone $coordinates;
145              
146 3         14 foreach my $pos (@{$mark_positions}) {
  3         11  
147 5         31 $coordinates->[$pos->[0]][$pos->[1]] = $mark;
148             }
149             }
150              
151 5         20 foreach my $pos_x (0 .. $#$coordinates) {
152 49         66 foreach my $pos_y (0 .. $#{$coordinates->[$pos_x]}) {
  49         93  
153 474         643 my $obj = $coordinates->[$pos_x][$pos_y];
154 474 100       1248 $lines[$pos_y][$pos_x] = $obj eq $mark ? $with : $markers_rev{$obj->type};
155             }
156             }
157              
158             return join "\n",
159             reverse
160 5         13 map { join '', @{$_} } @lines;
  51         66  
  51         238  
161             }
162              
163             1;
164              
165             __END__