File Coverage

blib/lib/Games/Maze/SVG/Rect.pm

Criterion	Covered	Total	%
statement	94	97	96.9
branch	19	20	95.0
condition	4	5	80.0
subroutine	17	18	94.4
pod	10	10	100.0
total	144	150	96.0

#  SVG maze output
#  Performs transformation, cleanup, and printing of output of Games::Maze

package Games::Maze::SVG::Rect;

use base Games::Maze::SVG;

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

=head1 NAME

Games::Maze::SVG::Rect - Build rectangular mazes in SVG.

=head1 VERSION

Version 0.90

=cut

our $VERSION = 0.90;

=head1 SYNOPSIS

Games::Maze::SVG::Rect uses the Games::Maze module to create mazes in SVG.

    use Games::Maze::SVG;

    my $foo = Games::Maze::SVG->new( 'Rect' );
    ...

=cut

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

# ----------------
#  Shape transformation tables
my %Blocks = (
    ': - |' => 'ul',
    ':-  |' => 'ur',
    ': -| ' => 'll',
    ':- | ' => 'lr',
    ':--  ' => 'h',
    '-::  ' => 'h',
    ':  ||' => 'v',
    '|  ::' => 'v',
    ':-   ' => 'l',
    ': -  ' => 'r',
    ':  | ' => 't',
    ':   |' => 'd',
    ': -||' => 'tr',
    ':- ||' => 'tl',
    ':--| ' => 'tu',
    ':-- |' => 'td',
    ':--||' => 'cross',
    ':.- |' => 'oul',
    ':- .|' => 'our',
    ': -.|' => 'oul',
    ':-. |' => 'our',
    ':.-.|' => 'oul',
    ':-..|' => 'our',
    ':.-| ' => 'oll',
    ':-.| ' => 'olr',
    ': -|.' => 'oll',
    ':- |.' => 'olr',
    ':.-|.' => 'oll',
    ':-.|.' => 'olr',
    ':--. ' => 'oh',
    '-::. ' => 'oh',
    ':-- .' => 'oh',
    '-:: .' => 'oh',
    ':. ||' => 'ov',
    '|. ::' => 'ov',
    ': .||' => 'ov',
    '| .::' => 'ov',
    ':- . ' => 'ol',
    ': -. ' => 'or',
    ':-.  ' => 'ol',
    ':.-  ' => 'or',
    ':-  .' => 'ol',
    ': - .' => 'or',
    ':. | ' => 'ot',
    ':.  |' => 'od',
    ': .| ' => 'ot',
    ': . |' => 'od',
    ':  |.' => 'ot',
    ':  .|' => 'od',
    ':. |.' => 'ot',
    ':. .|' => 'od',
    ': .|.' => 'ot',
    ': ..|' => 'od',
    ':.-||' => 'otr',
    ':-.||' => 'otl',
    ':--|.' => 'otu',
    ':--.|' => 'otd',
);

my %Walls = _get_wall_forms();

=head1 FUNCTIONS

=cut

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

=over 4

=item new

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

=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 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} = 'Quad';
    $obj->{mazeparms}->{form} = 'Rectangle';
    $obj->{scriptname}        = "rectmaze.es";
    $obj->{dx}                = DELTA_X;
    $obj->{dy}                = DELTA_Y;

    return bless $obj, $class;
}

=item is_hex

Method always returns false.

=cut

sub is_hex
{
    return;
}

=item is_hex_shaped

Method always returns false.

=cut

sub is_hex_shaped
{
    return;
}

=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 rectangular grid from ascii format to SVG definition
   references.

=over 4

=item $rows

Reference to an array of rows

=item $walls

String specifying wall format.

=back

=cut

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

    my $sp = 'bevel' eq ( $walls || q{} ) ? q{.} : q{ };
    remove_horiz_padding( $rows );

    # transform the printout into block commands
    my $height = @{$rows};
    my $width  = @{ $rows->[0] };
    for ( my $r = 0; $r < $height; ++$r )
    {
        for ( my $c = 0; $c < $width; ++$c )
        {
            if( $rows->[$r]->[$c] eq q{ } )
            {
                $out[$r]->[$c] = 0;
            }
            else
            {

                # convert the cell and its neighbors into a signature
                my $sig = $rows->[$r]->[$c]    # cell
                    . ( $c == 0 ? $sp : $rows->[$r]->[ $c - 1 ] )    # left neighbor
                    . ( $rows->[$r]->[ $c + 1 ] || $sp )             # right neighbor
                    . ( $r == 0 ? $sp : $rows->[ $r - 1 ]->[$c] )    # up neighbor
                    . ( $rows->[ $r + 1 ] ? $rows->[ $r + 1 ]->[$c] : $sp );    # down neighbor
                      # convert the signature into the block name
                croak "Missing block for '$sig'.\n" unless exists $Blocks{$sig};
                $out[$r]->[$c] = $Blocks{$sig};
            }
        }
    }

    return @{$rows} = @out;
}

=item remove_horiz_padding

Remove the extra horizontal space inserted to regularize the look
 of the rectangular maze

=over 4

=item $rows

Reference to an array of rows

=back

=cut

sub remove_horiz_padding
{
    my $rows = shift;

    for ( my $i = $#{ $rows->[0] }; $i > 0; $i -= 3 )
    {
        splice( @{$_}, $i - 1, 1 ) foreach ( @{$rows} );
    }

    # apparently trailing spaces that I wasn't aware of.
    foreach my $r ( @{$rows} )
    {
        pop @{$r} if $r->[-1] eq q{ };
    }

    return;
}

=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 = 2 * ( $x - 1 ) + 1;
    $y = 2 * ( $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 = 2 * ( $x - 1 ) + 1;
    $y = 2 * ( $y - 1 ) + 2;

    return ( $x, $y );
}

=item convert_sign_position

Convert the supplied x and y coordinates into the appropriate real coordinates
for a the position of the exit sign.

=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_sign_position
{
    my $self = shift;
    my ( $x, $y ) = @_;

    $x *= $self->dx();
    $y *= $self->dy();

    $x += 0.5 * $self->dx();

    # adjust bottom
    if( $y > $self->{height} / 2 )
    {
        $y += 2 * $self->dy();
    }
    else
    {
        $y -= $self->dy();
    }

    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__