File Coverage

blib/lib/Games/Maze/SVG/HexCells.pm
Criterion Covered Total %
statement 85 87 97.7
branch 15 16 93.7
condition 16 16 100.0
subroutine 15 16 93.7
pod 6 6 100.0
total 137 141 97.1


line stmt bran cond sub pod time code
1             # SVG maze output
2             # Handles the common code between Hex and RectHex mazes.
3              
4             package Games::Maze::SVG::HexCells;
5              
6 28     28   198 use base Games::Maze::SVG;
  28         225  
  28         4302  
7              
8 28     28   179 use Carp;
  28         60  
  28         2763  
9 28     28   192 use Games::Maze;
  28         78  
  28         731  
10 28     28   176 use strict;
  28         52  
  28         1046  
11 28     28   173 use warnings;
  28         72  
  28         2822  
12              
13             =head1 NAME
14              
15             Games::Maze::SVG::HexCells - Base class for Hex and RectHex mazes.
16              
17             =head1 VERSION
18              
19             Version 0.80
20              
21             =cut
22              
23             our $VERSION = 0.80;
24              
25             =head1 SYNOPSIS
26              
27             The class is intended to only be used as a base class. It should not
28             instatiated directly.
29              
30             =cut
31              
32 28     28   149 use constant DELTA_X => 10;
  28         64  
  28         2036  
33 28     28   153 use constant DELTA_Y => 10;
  28         48  
  28         60216  
34              
35             # ----------------
36             # Shape transformation tables
37              
38             # in-line
39             # l r dl dr
40             my %Blocks = (
41             ' _/ ' => 'tl',
42             '_ \\' => 'tr',
43             '\\_ ' => 'bl',
44             '_/ ' => 'br',
45             ' / \\' => 'cl',
46             '\\ / ' => 'cr',
47             '__ ' => 'hz',
48             '_ ' => 'hzl',
49             ' _ ' => 'hzr',
50             '\\_/ ' => 'yr',
51             '_/ \\' => 'yl',
52             '\\ ' => 'slb',
53             ' \\' => 'slt',
54             ' / ' => 'srb',
55             ' / ' => 'srt',
56             ' /' => 0,
57             ' \\ ' => 0,
58             '/ \\_' => 0,
59             ' __' => 0,
60             ' \\_/' => 0,
61             ' \\ ' => 0,
62             '/ ' => 0,
63             ' \\_' => 0,
64             ' _/' => 0,
65             ' ' => 0,
66             '/ \\ ' => 0,
67             ' \\ /' => 0,
68             '/ _' => 0,
69             ' \\_ ' => 0,
70             ' _' => 0,
71             ' _ ' => 0,
72             '/ ' => 0,
73             );
74              
75             # Between lines
76             # l r dl dr
77             my %BlocksBetween = (
78             ' /' => 'sr',
79             ' \\_/' => 'sr',
80             ' _/' => 'sr',
81             ' \\ /' => 'sr',
82             '_ \\' => 'sl',
83             ' / \\' => 'sl',
84             ' \\' => 'sl',
85             '_/ \\' => 'sl',
86             ' _/ ' => q{$},
87             ' \\ ' => q{$},
88             '/ \\_' => q{$},
89             '\\ / ' => q{$},
90             ' \\_' => q{$},
91             '/ \\ ' => q{$},
92             '\\_/ ' => q{$},
93             '__ ' => 0,
94             ' __' => 0,
95             ' ' => 0,
96             '_/ ' => 0,
97             '/ _' => 0,
98             ' \\_ ' => 0,
99             '\\ ' => 0,
100             '_ ' => 0,
101             ' _' => 0,
102             ' _ ' => 0,
103             ' _ ' => 0,
104             '\\_ ' => 0,
105             ' \\ ' => 0,
106             ' / ' => 0,
107             '/ ' => 0,
108             ' / ' => 0,
109             );
110              
111             my %Walls = _get_wall_forms();
112              
113             =head1 FUNCTIONS
114              
115             =cut
116              
117             # ----------------------------------------------
118             # Subroutines
119              
120             =over 4
121              
122             =item new
123              
124             Create a new Games::Maze::SVG object. Supports the following named parameters:
125              
126             Takes one positional parameter that is the maze type: Rect, RectHex, or Hex
127              
128             =over 4
129              
130             =item wallform
131              
132             String naming the wall format. Legal values are bevel, round, roundcorners,
133             and straight.
134              
135             =item crumb
136              
137             String describing the breadcrumb design. Legal values are dash,
138             dot, line, and none
139              
140             =item dx
141              
142             The size of the tiles in the X direction.
143              
144             =item dy
145              
146             The size of the tiles in the Y direction.
147              
148             =item dir
149              
150             Directory in which to find the ecmascript for the maze interactivity. Should
151             either be relative, or in URL form.
152              
153             =back
154              
155             =cut
156              
157             sub new
158             {
159 16     16 1 44 my $class = shift;
160              
161 16         90 my $obj = { Games::Maze::SVG::init_object( @_ ), @_, };
162              
163 16 100       102 if( !exists $Walls{ $obj->{wallform} } )
164             {
165 2         54 my $forms = join( ", ", sort keys %Walls );
166 2         767 croak "\n'$obj->{wallform}' is not a valid wall form.\nTry one of: $forms\n\n";
167             }
168              
169 14         56 $obj->{mazeparms}->{cell} = 'Hex';
170 14         48 $obj->{scriptname} = "hexmaze.es";
171 14         45 $obj->{dx} = DELTA_X;
172 14         41 $obj->{dy} = DELTA_Y;
173              
174 14         79 return bless $obj, $class;
175             }
176              
177             =item set_wall_form
178              
179             Set the wall format for the current maze.
180              
181             =over 4
182              
183             =item $form
184              
185             String specifying a wall format.
186              
187             =back
188              
189             Returns a reference to self for chaining.
190              
191             =cut
192              
193             sub set_wall_form
194             {
195 8     8 1 8470 my $self = shift;
196 8         14 my $form = shift;
197              
198 8 100       30 if( exists $Walls{$form} )
199             {
200 6         29 $self->{wallform} = $form;
201             }
202             else
203             {
204 2         19 my $forms = join( ", ", sort keys %Walls );
205 2         425 croak "\n'$form' is not a valid wall form.\nTry one of: $forms\n\n";
206             }
207              
208 6         29 return $self;
209             }
210              
211             =item transform_grid
212              
213             Convert the hexagonal grid from ascii format to SVG definition
214             references.
215              
216             =over 4
217              
218             =item $rows
219              
220             Reference to an array of rows
221              
222             =item $walls
223              
224             String specifying wall format. (Unused at present.)
225              
226             =back
227              
228             =cut
229              
230             sub transform_grid
231             {
232 10     10 1 94907 my $self = shift;
233 10         24 my $rows = shift;
234 10         19 my $walls = shift;
235 10         35 my @out = ();
236              
237             # transform the printout into block commands
238 10         15 my $height = @{$rows};
  10         38  
239 10         18 my $width = @{ $rows->[0] } + 2;
  10         26  
240              
241 10         54 for ( my $r = 0; $r < $height - 1; ++$r )
242             {
243              
244             # on line
245 54         117 push @out, _calc_on_line( $rows, $r, $width );
246              
247             # between
248 54         117 push @out, _calc_between_line( $rows, $r, $width );
249             }
250 10         86 push @out, _calc_on_line( $rows, $height - 1, $width );
251              
252 8         61 return @{$rows} = @out;
  8         204  
253             }
254              
255             sub _calc_between_line
256             {
257 54     54   82 my $rows = shift;
258 54         56 my $index = shift;
259 54         53 my $width = shift;
260 54         74 my @out = ();
261              
262 54         135 for ( my $c = 0; $c < $width; ++$c )
263             {
264 990 100 100     7312 my $sig =
    100 100        
      100        
      100        
265             ( $c ? $rows->[$index][ $c - 1 ] || q{ } : q{ } )
266             . ( $rows->[$index][$c] || q{ } )
267             . ( $c ? $rows->[ $index + 1 ][ $c - 1 ] || q{ } : q{ } )
268             . ( $rows->[ $index + 1 ][$c] || q{ } );
269              
270 990 50       7634 croak "Missing between block for '$sig'.\n" unless exists $BlocksBetween{$sig};
271              
272 990         2542 push @out, $BlocksBetween{$sig};
273             }
274              
275 54         233 return \@out;
276             }
277              
278             sub _calc_on_line
279             {
280 64     64   77 my $rows = shift;
281 64         74 my $index = shift;
282 64         67 my $width = shift;
283 64         89 my @out = ();
284              
285 64         161 for ( my $c = 0; $c < $width; ++$c )
286             {
287 1094 100 100     8434 my $sig =
    100 100        
      100        
      100        
288             ( $c ? $rows->[$index][ $c - 1 ] || q{ } : q{ } )
289             . ( $rows->[$index][$c] || q{ } )
290             . ( $c ? $rows->[ $index + 1 ][ $c - 1 ] || q{ } : q{ } )
291             . ( $rows->[ $index + 1 ][$c] || q{ } );
292              
293 1094 100       3020 croak "Missing block for '$sig'.\n" unless exists $Blocks{$sig};
294              
295 1092         7388 push @out, $Blocks{$sig};
296             }
297              
298 62         208 return \@out;
299             }
300              
301             =item wall_definitions
302              
303             Method that returns the definition for the shapes used to build the walls.
304              
305             =cut
306              
307             sub wall_definitions
308             {
309 0     0 1 0 my $self = shift;
310              
311 0         0 return $Walls{ $self->{wallform} };
312             }
313              
314             # _get_wall_forms
315             #
316             #Extract the wall forms from the DATA file handle.
317             #
318             #Returns a hash of wall forms.
319              
320             sub _get_wall_forms
321             {
322 28     28   159 local $/ = "\n===\n";
323 28         944 chomp( my @list = );
324              
325 28         109 $/ = "\n";
326 28         69 chomp( @list );
327              
328 28         222 return @list;
329             }
330              
331             =item convert_start_position
332              
333             Convert the supplied x and y coordinates into the appropriate real coordinates
334             for a start position on this map.
335              
336             =over 4
337              
338             =item $x x coord from the maze
339              
340             =item $y y coord from the maze
341              
342             =back
343              
344             returns a two element list containing (x, y).
345              
346             =cut
347              
348             sub convert_start_position
349             {
350 4     4 1 11167 my $self = shift;
351 4         8 my ( $x, $y ) = @_;
352              
353 4         13 $x = 3 * ( $x - 1 ) + 2;
354 4         8 $y = 4 * ( $y - 1 );
355              
356 4         12 return ( $x, $y );
357             }
358              
359             =item convert_end_position
360              
361             Convert the supplied x and y coordinates into the appropriate real coordinates
362             for a end position on this map.
363              
364             =over 4
365              
366             =item $x x coord from the maze
367              
368             =item $y y coord from the maze
369              
370             =back
371              
372             returns a two element list containing (x, y).
373              
374             =cut
375              
376             sub convert_end_position
377             {
378 4     4 1 4782 my $self = shift;
379 4         11 my ( $x, $y ) = @_;
380              
381 4         10 $x = 3 * ( $x - 1 ) + 2;
382 4         9 $y = 4 * ( $y ) + 2;
383              
384 4         12 return ( $x, $y );
385             }
386              
387             =back
388              
389             =head1 AUTHOR
390              
391             G. Wade Johnson, C<< >>
392              
393             =head1 BUGS
394              
395             Please report any bugs or feature requests to
396             C, or through the web interface at
397             L.
398             I will be notified, and then you'll automatically be notified of progress on
399             your bug as I make changes.
400              
401             =head1 ACKNOWLEDGEMENTS
402              
403             Thanks go to Valen Johnson and Jason Wood for extensive test play of the
404             mazes.
405              
406             =head1 COPYRIGHT & LICENSE
407              
408             Copyright 2004-2006 G. Wade Johnson, all rights reserved.
409              
410             This program is free software; you can redistribute it and/or modify it
411             under the same terms as Perl itself.
412              
413             =cut
414              
415             1;
416              
417             __DATA__