File Coverage

blib/lib/Games/Trackword.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	22	22	100.0
condition	3	3	100.0
subroutine	9	9	100.0
pod	3	3	100.0
total	87	87	100.0

package Games::Trackword;

use strict;
use warnings;

use vars qw($VERSION);
$VERSION = '1.08';

#----------------------------------------------------------------------------

=head1 NAME

Games::Trackword - Find words on a Trackword grid.

=head1 SYNOPSIS

  use Games::Trackword;

  my $board = Games::Trackword->new('TRA WKC ORD');

  foreach my $word (@wordlist) {
    print "OK $word\n" if $board->has_word($word);
  }

=head1 DESCRIPTION

This module lets you set up a Trackword grid and query whether or not it is
possible to find words on that grid.

Note that although Trackword is similar to Boggle, you are not restricted by
the size of the grid and you cannot move diagonally between each letter, you
may only move up/down or left/right.

=cut

my @directions = ([-1,0],[0,-1],[1,0],[0,1]);

sub new {
	my ($class, $string) = @_;
	bless {
		_board => _ring_fence($string),
		_has  => { map { $_ => 1 } grep /\S/, split //, uc $string },
	}, $class;
}

sub qu {
  my $self = shift;
  my $this = shift;

  $self->{_qu} = 1;	# Boggle style
  $self->{_qu} = 0	if(defined $this && !$this);
}

sub has_word {
	my $self = shift;
	my $word = uc shift;
	my $board = $self->{_board};

	if($self->{_qu}) {
		return if $word =~ /Q(?!U)/; # Can't have lone Q in boggle.
		$word =~ s/QU/Q/;
	}

	return unless $self->_have_letters($word);

	my $last = chop $word;
	my $rows = scalar(@$board)-1;
	foreach my $posy (0..$rows) {
		my $cols = scalar(@{ $board->[$posy] })-1;
		foreach my $posx (0..$cols) {
			if($board->[$posy][$posx] eq $last) {
				return 1	if(_can_play($board, $word.$last, $posy, $posx));
			}
		}
	}

	return 0;
}

# Quick sanity check to stop us looking for words with letters we don't
# have. We don't check to ensure that we have ENOUGH copies of each
# letter in the word, as that is considerably slower.
sub _have_letters {
	my ($self, $word) = @_;
	while (my $let = chop $word) { return unless $self->{_has}->{$let}; }
	return 1;
}

sub _can_play {
	my ($board, $word, $posy, $posx) = @_;
	if (length $word > 1) {
		my $last = chop $word;
		if($board->[$posy][$posx] eq $last) {
			local $board->[$posy][$posx] = "-";
			foreach my $dir (@directions) {
				return 1	if(_can_play($board, $word, $posy+$dir->[0], $posx+$dir->[1]));
			}
		}
		return 0;
	}
	return ($board->[$posy][$posx] eq $word) ? 1 : 0;
}

sub _ring_fence {
	my @block = split /\s/, uc $_[0];
	my $width = length($block[0])+2;
	push my @board, [('-') x $width],
	                (map {['-',split(//),'-']} @block),
	                [('-') x $width];
	return \@board;
}

1;

__END__