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

#  SVG maze output
#  Handles the common code between Hex and RectHex mazes.

package Games::Maze::SVG::HexCells;

use base Games::Maze::SVG;

use Carp;
use Games::Maze;
use strict;
use warnings;

=head1 NAME

Games::Maze::SVG::HexCells - Base class for Hex and RectHex mazes.

=head1 VERSION

Version 0.80

=cut

our $VERSION = 0.80;

=head1 SYNOPSIS

The class is intended to only be used as a base class. It should not
instatiated directly.

=cut

use constant DELTA_X => 10;
use constant DELTA_Y => 10;

# ----------------
#  Shape transformation tables

# in-line
# l r dl dr
my %Blocks = (
    ' _/ '  => 'tl',
    '_  \\' => 'tr',
    '\\_  ' => 'bl',
    '_/  '  => 'br',
    ' / \\' => 'cl',
    '\\ / ' => 'cr',
    '__  '  => 'hz',
    '_   '  => 'hzl',
    ' _  '  => 'hzr',
    '\\_/ ' => 'yr',
    '_/ \\' => 'yl',
    '\\   ' => 'slb',
    '   \\' => 'slt',
    ' /  '  => 'srb',
    '  / '  => 'srt',
    '   /'  => 0,
    '  \\ ' => 0,
    '/ \\_' => 0,
    '  __'  => 0,
    ' \\_/' => 0,
    ' \\  ' => 0,
    '/   '  => 0,
    '  \\_' => 0,
    '  _/'  => 0,
    '    '  => 0,
    '/ \\ ' => 0,
    ' \\ /' => 0,
    '/  _'  => 0,
    ' \\_ ' => 0,
    '   _'  => 0,
    '  _ '  => 0,
    '/   '  => 0,
);

# Between lines
# l r dl dr
my %BlocksBetween = (
    '   /'  => 'sr',
    ' \\_/' => 'sr',
    '  _/'  => 'sr',
    ' \\ /' => 'sr',
    '_  \\' => 'sl',
    ' / \\' => 'sl',
    '   \\' => 'sl',
    '_/ \\' => 'sl',
    ' _/ '  => q{$},
    '  \\ ' => q{$},
    '/ \\_' => q{$},
    '\\ / ' => q{$},
    '  \\_' => q{$},
    '/ \\ ' => q{$},
    '\\_/ ' => q{$},
    '__  '  => 0,
    '  __'  => 0,
    '    '  => 0,
    '_/  '  => 0,
    '/  _'  => 0,
    ' \\_ ' => 0,
    '\\   ' => 0,
    '_   '  => 0,
    '   _'  => 0,
    '  _ '  => 0,
    ' _  '  => 0,
    '\\_  ' => 0,
    ' \\  ' => 0,
    '  / '  => 0,
    '/   '  => 0,
    ' /  '  => 0,
);

my %Walls = _get_wall_forms();

=head1 FUNCTIONS

=cut

# ----------------------------------------------
#  Subroutines

=over 4

=item new

Create a new Games::Maze::SVG object. Supports the following named parameters:

Takes one positional parameter that is the maze type: Rect, RectHex, or Hex

=over 4

=item wallform

String naming the wall format. Legal values are bevel, round, roundcorners,
and straight.

=item crumb

String describing the breadcrumb design. Legal values are dash,
dot, line, and none

=item dx

The size of the tiles in the X direction.

=item dy

The size of the tiles in the Y direction.

=item dir

Directory in which to find the ecmascript for the maze interactivity. Should
either be relative, or in URL form.

=back

=cut

sub new
{
    my $class = shift;

    my $obj = { Games::Maze::SVG::init_object( @_ ), @_, };

    if( !exists $Walls{ $obj->{wallform} } )
    {
        my $forms = join( ", ", sort keys %Walls );
        croak "\n'$obj->{wallform}' is not a valid wall form.\nTry one of: $forms\n\n";
    }

    $obj->{mazeparms}->{cell} = 'Hex';
    $obj->{scriptname}        = "hexmaze.es";
    $obj->{dx}                = DELTA_X;
    $obj->{dy}                = DELTA_Y;

    return bless $obj, $class;
}

=item set_wall_form

Set the wall format for the current maze.

=over 4

=item $form

String specifying a wall format.

=back

Returns a reference to self for chaining.

=cut

sub set_wall_form
{
    my $self = shift;
    my $form = shift;

    if( exists $Walls{$form} )
    {
        $self->{wallform} = $form;
    }
    else
    {
        my $forms = join( ", ", sort keys %Walls );
        croak "\n'$form' is not a valid wall form.\nTry one of: $forms\n\n";
    }

    return $self;
}

=item transform_grid

Convert the hexagonal grid from ascii format to SVG definition
 references.

=over 4

=item $rows

Reference to an array of rows

=item $walls

String specifying wall format. (Unused at present.)

=back

=cut

sub transform_grid
{
    my $self  = shift;
    my $rows  = shift;
    my $walls = shift;
    my @out   = ();

    # transform the printout into block commands
    my $height = @{$rows};
    my $width  = @{ $rows->[0] } + 2;

    for ( my $r = 0; $r < $height - 1; ++$r )
    {

        # on line
        push @out, _calc_on_line( $rows, $r, $width );

        # between
        push @out, _calc_between_line( $rows, $r, $width );
    }
    push @out, _calc_on_line( $rows, $height - 1, $width );

    return @{$rows} = @out;
}

sub _calc_between_line
{
    my $rows  = shift;
    my $index = shift;
    my $width = shift;
    my @out   = ();

    for ( my $c = 0; $c < $width; ++$c )
    {
        my $sig =
              ( $c ? $rows->[$index][ $c - 1 ] || q{ } : q{ } )
            . ( $rows->[$index][$c] || q{ } )
            . ( $c ? $rows->[ $index + 1 ][ $c - 1 ] || q{ } : q{ } )
            . ( $rows->[ $index + 1 ][$c] || q{ } );

        croak "Missing between block for '$sig'.\n" unless exists $BlocksBetween{$sig};

        push @out, $BlocksBetween{$sig};
    }

    return \@out;
}

sub _calc_on_line
{
    my $rows  = shift;
    my $index = shift;
    my $width = shift;
    my @out   = ();

    for ( my $c = 0; $c < $width; ++$c )
    {
        my $sig =
              ( $c ? $rows->[$index][ $c - 1 ] || q{ } : q{ } )
            . ( $rows->[$index][$c] || q{ } )
            . ( $c ? $rows->[ $index + 1 ][ $c - 1 ] || q{ } : q{ } )
            . ( $rows->[ $index + 1 ][$c] || q{ } );

        croak "Missing block for '$sig'.\n" unless exists $Blocks{$sig};

        push @out, $Blocks{$sig};
    }

    return \@out;
}

=item wall_definitions

Method that returns the definition for the shapes used to build the walls.

=cut

sub wall_definitions
{
    my $self = shift;

    return $Walls{ $self->{wallform} };
}

# _get_wall_forms
#
#Extract the wall forms from the DATA file handle.
#
#Returns a hash of wall forms.

sub _get_wall_forms
{
    local $/ = "\n===\n";
    chomp( my @list =  );

    $/ = "\n";
    chomp( @list );

    return @list;
}

=item convert_start_position

Convert the supplied x and y coordinates into the appropriate real coordinates
for a start position on this map.

=over 4

=item $x x coord from the maze

=item $y y coord from the maze

=back

returns a two element list containing (x, y).

=cut

sub convert_start_position
{
    my $self = shift;
    my ( $x, $y ) = @_;

    $x = 3 * ( $x - 1 ) + 2;
    $y = 4 * ( $y - 1 );

    return ( $x, $y );
}

=item convert_end_position

Convert the supplied x and y coordinates into the appropriate real coordinates
for a end position on this map.

=over 4

=item $x x coord from the maze

=item $y y coord from the maze

=back

returns a two element list containing (x, y).

=cut

sub convert_end_position
{
    my $self = shift;
    my ( $x, $y ) = @_;

    $x = 3 * ( $x - 1 ) + 2;
    $y = 4 * ( $y ) + 2;

    return ( $x, $y );
}

=back

=head1 AUTHOR

G. Wade Johnson, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

Thanks go to Valen Johnson and Jason Wood for extensive test play of the
mazes.

=head1 COPYRIGHT & LICENSE

Copyright 2004-2006 G. Wade Johnson, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;

__DATA__