File Coverage

blib/lib/Array/Tour.pm

Criterion	Covered	Total	%
statement	143	239	59.8
branch	17	76	22.3
condition	5	11	45.4
subroutine	30	43	69.7
pod	14	15	93.3
total	209	384	54.4

=head1 NAME

Array::Tour - Base class for Array Tours.

=head1 SYNOPSIS

  #
  # For a new package.  Add extra methods and internal attributes afterwards.
  #
  package Array::Tour::NewTypeOfTour
  use base qw(Array::Tour);

  # (Code goes here).

or

  #
  # Make use of the constants in the package.
  #
  use Array::Tour qw(:directions);
  use Array::Tour qw(:status);

or

  #
  # Use Array::Tour for its default 'typewriter' tour of the array.
  #
  use Array::Tour;

  my $by_row = Array::Tour->new(dimensions => [24, 80, 1]);


=head1 PREREQUISITES

Perl 5.8 or later. This is the version of perl under which this module
was developed.

=head1 DESCRIPTION

Array::Tour is a base class for iterators that traverse the cells of an
array. This class should provide most of the methods needed for any type
of tour, whether it needs to visit each cell or not, and whether
the tour needs to be a continuous path or not.

The iterator provides coordinates and directions.  It does not define
the array.  This leaves the user of the tour object free to
define the form of the array or the data structure behind it without
restrictions from the tour object.

By itself without any subclassing or options, the Array::Tour class traverses a
simple left-to-right, top-to-bottom typewriter path. There are options to change
the direction or rotation of the path.

=cut

package Array::Tour;
use 5.008;
use strict;
use warnings;
use integer;

use vars qw(@ISA);
require Exporter;

@ISA = qw(Exporter);

use vars qw(%EXPORT_TAGS @EXPORT_OK);
%EXPORT_TAGS = (
	'directions' => [ qw ( NoDirection
		North NorthWest West SouthWest Ceiling
		South SouthEast East NorthEast Floor
		SetPosition
	)],
	'status' => [ qw (START TOURING STOP)]
);

@EXPORT_OK = ( @{ $EXPORT_TAGS{'directions'} }, @{ $EXPORT_TAGS{'status'} } );

our $VERSION = '0.06';

#
# Directions.
#
# The eight possible directions that one can move from a cell, including
# "null" direction NoDirection, and position change indicator SetPosition.
#
use constant NoDirection => 0x0000;
use constant North       => 0x0001;	# 0;
use constant NorthWest   => 0x0002;	# 1;
use constant West        => 0x0004;	# 2;
use constant SouthWest   => 0x0008;	# 3;
use constant Ceiling     => 0x0010;	# 4;
use constant South       => 0x0020;	# 5;
use constant SouthEast   => 0x0040;	# 6;
use constant East        => 0x0080;	# 7;
use constant NorthEast   => 0x0100;	# 8;
use constant Floor       => 0x0200;	# 9;
use constant SetPosition => 0x8000;	# 15;

#
# {tourstatus} constants.
#
use constant START	=> 0;
use constant TOURING	=> 1;
use constant STOP	=> 2;


=head2 Tour Object Methods

=head3 new([ => value, ...])

Creates the object with its attributes.

With the exception of C and C, attributes are set using the
internal method _set(). This means that subclasses should not override new(),
but instead provide their own _set() method to handle their own attributes.

In addition to C and C, new() also creates internal
attributes that may be used by subclasses. See the Attributes section for more
details.

=cut

sub new
{
	my $class = shift;
	my $self = {};

	#
	# We are copying from an existing Tour object?
	#
	if (ref $class)
	{
		if ($class->isa("Array::Tour"))
		{
			$class->_copy($self, @_);
			return bless($self, ref $class);
		}

		warn "Attempts to create an Array Touring object from a '",
			ref $class, "' object fail.\n";
		return undef;
	}

	#
	# Starting from scratch.
	#
	bless($self, $class);
	my %attributes = @_;
	$self->_set_dimensions(%attributes);
	$self->_set_offset(%attributes);
	delete @attributes{qw(dimensions offset)};
	$self->{position} = [0, 0, 0];
	$self->{start} = [0, 0, 0];
	$self->{array} = undef;
	$self->{tourlength} = 1;
	map {$self->{tourlength} *= $_} $self->get_dimensions();
	$self->{tourstatus} = START;
	$self->{odometer} = 0;
	$self->_set(%attributes);

	return $self;
}

=head3 reset()

  $tour->reset([ => value, ...])

Reset the object by returning its internal state to its original form.
Optionally change some of the characteristics using the same parameters
found in the new() method.

=cut

sub reset
{
	my $self = shift;
	my %newargs = @_;

	my %params = $self->describe();
	$params{position} = [0, 0, 0];
	$params{tourlength} = 1;
	$params{tourstatus} = START;
	$params{odometer} = 0;
	$params{array} = undef if ($self->_uses_array());

	#
	# Apply any options passed in.
	#
	map {$params{$_} = $newargs{$_}} keys %newargs;

	return $self->_set(%params);
}

=head3 has_next()

Returns 1 if there is more to the tour, 0 if finished.

=cut

sub has_next
{
	my $self = shift;
	return ($self->{tourstatus} == STOP)? 0: 1;
}

=head3 get_dimensions()

Returns an array of the dimensions.

=cut

sub get_dimensions
{
	my $self = shift;
	return @{$self->{dimensions}};
}

=head3 direction()

Returns the current direction as found in the :directions EXPORT tag.

=cut

sub direction
{
	my $self = shift;
	return (${$self->{position}}[0] == 0)? NoDirection: East;
}

=head3 opposite_direction()

Return the direction opposite from the current direction.

=cut

sub opposite_direction
{
	my $self = shift;
	my $dir = $self->direction();
	return NoDirection if ($dir == NoDirection);
	return ($dir <=  Ceiling )? ($dir << 5): ($dir >> 5);
}

=head3 say_direction()

Return the name in English of the current direction.

=cut

sub say_direction
{
	my $self = shift;
	my $dir = $self->direction();

	return $self->direction_name($dir);
}

=head3 direction_name()

Return the name in English of the direction passed in.

   print $tour->direction_name(NorthWest), " is ", NorthWest, "\n";

=cut

sub direction_name
{
	my $self = shift;
	my($dir) = @_;

	return q(NoDirection) if ($dir == NoDirection);
	return q(North) if ($dir == North);
	return q(NorthWest) if ($dir == NorthWest);
	return q(West) if ($dir == West);
	return q(SouthWest) if ($dir == SouthWest);
	return q(Ceiling) if ($dir == Ceiling);
	return q(South) if ($dir == South);
	return q(SouthEast) if ($dir == SouthEast);
	return q(East) if ($dir == East);
	return q(NorthEast) if ($dir == NorthEast);
	return q(Floor) if ($dir == Floor);
	if ($dir == SetPosition)
	{
		my @p = @{$self->get_position()};
		return q(SetPosition) . "[" . join(", ", @p) . "]";
	}

	return q(unknown direction);
};

=head3 get_position()

Return a reference to an array of coordinates of the current position.

    @absolute_pos = @{$self->get_position()};

=cut

sub get_position
{
	my $self = shift;
	return $self->{position};
}

=head3 get_offset()

Return a reference to an array of offsets to be added to the current position.

    @offset = @{$self->get_offset()};

=cut

sub get_offset
{
	my $self = shift;
	return $self->{offset};
}

=head3 adjusted_position()

Return a reference to an array of coordinates that are created from the position
plus the offset. Used by the next() method.

    @current_pos = @{$self->adjusted_position()};

=cut

sub adjusted_position
{
	my $self = shift;

	my @position = @{ $self->{position} };
	my @offset = @{ $self->{offset} };
	map {$position[$_] += $offset[$_]} (0..$#position);
	return \@position;
}

=head3 next()

Returns an array reference to the next coordinates to use. Returns
undef if the iterator is finished.

    my $ctr = 1;
    my $tour = Array::Tour->new(dimensions => 64);

    while (my $cref = $tour->next())
    {
        my($x_coord, $y_coord, $z_coord) = @{$cref};
        $grid[$y_coord, $x_coord] = isprime($ctr++);
    }

The above example would look like a completed Sieve of Eratothenes in the array
@grid.

=cut

sub next
{
	my $self = shift;

	return undef unless ($self->has_next());

	#
	# Set up the conditions for the pacing.
	#
	if ($self->{tourstatus} == START)
	{
		$self->{tourstatus} = TOURING;
	}
	else
	{
		#
		# Move to the next cell, checking to see if we've
		# reached the end of the row/plane/cube.
		#
		my($dim, $lastdim) = (0, scalar @{$self->{dimensions}});
		while ($dim < $lastdim and ${$self->{position}}[$dim] == ${$self->{dimensions}}[$dim] - 1)
		{
			${$self->{position}}[$dim++] = 0;
		}
		${$self->{position}}[$dim] += 1 unless ($dim == $lastdim);
	}

	$self->{tourstatus} = STOP if (++$self->{odometer} == $self->{tourlength});
	return $self->adjusted_position();
}

=head3 get_array()

Return a reference to the internally generated array.

    $arrayref = $self->get_array()

=cut

sub get_array
{
	my $self = shift;
	$self->_make_array() unless (defined $self->{array});
	return $self->{array};
}

=head3 describe()

Returns as a hash the attributes of the tour object. The hash may be
used to create a new object.

=cut

sub describe
{
	my $self = shift;
	return map {$_, $self->{$_}} grep(/^[a-z]/, keys %{$self});
}

=head2 Internal Tour Object Methods

=head3 _set_dimensions()

    my $tour = Array::Tour->new(dimensions => [12, 16]);

This works identically as

    my $tour = Array::Tour->new(dimensions => [12, 16, 1]);

If the grid is going to be square, a single integer is sufficient:

    my $tour = Array::Tour->new(dimensions => 16);

In both cases, the new() member funcntion calls _set_dimensions() and sets the
C attribute with a reference to a three dimensional array. The third
dimension is set to 1 if no value is given for it.

=cut

sub _set_dimensions
{
	my $self = shift;
	my(%params) = @_;
	my $dim = $params{dimensions} || [1, 1, 1];

	my @dimensions;

	if (ref $dim eq 'ARRAY')
	{
		@dimensions = map {$_ ||= 1} @{$dim};
		push @dimensions, 1 if (@dimensions < 1);
		push @dimensions, $dimensions[0] if (@dimensions < 2);
	}
	else
	{
		#
		# Square grid if only one dimension is defined.
		#
		@dimensions = ($dim) x 2;
	}
	push @dimensions, 1 if (@dimensions < 3);
	$self->{dimensions} = \@dimensions;

	return $self;
}

=head3 _set_offset()

The new() member funcntion calls _set_offset() and sets the C attribute
with a reference to an array of coordinates. This method matches the size of the
C array to the size of C, so _set_dimensions() must be called
beforhand.

=cut

sub _set_offset
{
	my $self = shift;
	my(%params) = @_;
	my $offsetref = $params{offset} || [0, 0, 0];

	$self->{offset} = $offsetref;

	my $dims = scalar @{$self->{dimensions}};
	my $offsets = scalar @{$self->{offset}};
	push @{$self->{offset}}, (0) x ($dims - $offsets) if ($dims > $offsets);
	return @{$self->{offset}};
}

=head3 _move_to()

	$position = $self->_move_to($direction);	# [$c, $r, $l]

Return a new position depending upon the direction taken. This does not set a
new position.

=cut

sub _move_to
{
	my $self = shift;
	my($dir) = @_;
	my($c, $r, $l) = @{ $self->{position} };

	--$r if ($dir & (North | NorthWest | NorthEast));
	++$r if ($dir & (South | SouthWest | SouthEast));
	++$c if ($dir & (East  | NorthEast | SouthEast));
	--$c if ($dir & (West  | NorthWest | SouthWest));
	++$l if ($dir & Floor);
	--$l if ($dir & Ceiling);
	return [$c, $r, $l];
}

=head3 _make_array()

	$self->_make_array();
or
	$self->_make_array($value);

Make an internal array for reference purposes. If no value to set the array cels
with is passed in, the array cells are set to zero by default.

=cut

sub _make_array
{
	my $self = shift;
	my $dflt = (scalar @_)? $_[0]: 0;
	my($cols, $rows, $lvls) = map {$_ - 1} @{$self->{dimensions}};

	my $m = $self->{array} = ([]);
	foreach my $l (0..$lvls)
	{
		foreach my $r (0..$rows)
		{
			foreach my $c (0..$cols)
			{
				$$m[$l][$r][$c] = $dflt;
			}
		}
	}
	return $self;
}

=head3 _set()

$self->_set(%attributes);

Take the parameters provided to new() and use them to set the
attributes of the touring object.

=cut

sub _set()
{
	my $self = shift;
	my(%params) = @_;

	warn "Unknown paramter $_" foreach (grep{$_ !~ /reverse/} (keys %params));
	return $self;
}

=head3 _uses_array()

Returns 0 or 1 depending upon whether there's an internal array to return.

=cut

sub _uses_array {my $self = shift; return 0;}

#
# dump_array
#
# @xlvls = $obj->dump_array($spr_fmt);
# $xstr = $obj->dump_array($spr_fmt);
#
# Returns a formatted string of all the cell values.  By default,
# the format string is " %04x", so the default output strings will
# be rows of hexadecimal numbers separated by a space.
#
# If called in a list context, returns a list of strings, each one
# representing a level. If called in a scalar context, returns a single
# string, each level separated by a single newline.
#
sub dump_array
{
	my $self = shift;
	my $format = $_[0] || " %04x";
	my($cols, $rows, $lvls) = map {$_ - 1} @{$self->{dimensions}};
	my $m = $self->{array};
	my @levels;

	foreach my $l (0..$lvls)
	{
		my $vxstr = "";
		foreach my $r (0..$rows)
		{
			foreach my $c (0..$cols)
			{
				$vxstr .= sprintf($format, $$m[$l][$r][$c]);
			}
			$vxstr .= "\n";
		}

		push @levels, $vxstr;
	}

	return wantarray? @levels: join("\n", @levels);
}

#
# $class->_copy($self);
#
# Duplicate the iterator.
#
sub _copy
{
	my($other, $self) = @_;
	foreach my $k (grep($_ !~ /_array/, keys %{$other}))
	{
		$self->{$k} = $other->{$k};
	}
	if ($other->uses_array())
	{
		# copy it.
	}
}

1;
__END__