Here's my try. It's a brute force breadth-first algorithm. It will report all possible cycle-free paths from the start word till the end word. By default, it will not change the same letter in succession (so it won't do
cone-code-core), but you can turn it on with
--same. Use
--dictionary to supply a dictionary of words (
/usr/share/dict/words by default). Use
--depth to give the maximum amount of words to be tried (0, the default, means no limit).
#!/usr/bin/perl
use strict;
use warnings;
use Getopt::Long;
my ($start, $end, $dictionary, $depth, $verbose, $same);
$depth = 0;
$verbose = 1;
$dictionary = "/usr/share/dict/words";
GetOptions ('start=s', \$start, # Start word ($ARGV[0])
'end=s', \$end, # End word ($ARGV[1])
'dictionary=s', \$dictionary, # Dictionary, (/usr/share/d
+ict/words)
'depth=s', \$depth, # Max depth (0 means infini
+te)
'verbose=i', \$verbose, # Print progess
'same', \$same, # If set, allow the same le
+tter
# to be changed in successi
+on.
);
$| = 1 if $verbose;
$start = shift if !defined $start && @ARGV;
$end = shift if !defined $end && @ARGV;
die "Need two different words of equal length\n"
unless defined $start &&
defined $end &&
length $start == length $end &&
$start ne $end;
my $L = length $start;
# Read in the dictionary. Weed out words of inappropriate lengths, and
# words containing characters that aren't lowercase letters. Add in th
+e
# start and end words (so you can use 'perl') and remove duplicates.
my @words = do {my %seen; local @ARGV = ($dictionary);
grep {$L == length && !/[^a-z]/ && !$seen{$_}++}
map {chomp; $_} <ARGV>, $start, $end};
# Structure to keep track of a possibility:
# 0: list of words used to get to this possition.
# 1: hash of words used sofar.
# 2: position of last letter change.
my @tries = ([[$start], {$start => 1}, $L]);
my $tries = 0; # How many positions have we tried so far?
my @solutions; # List of solutions.
while (@tries) {
my $try = shift @tries;
my $last = $$try[0][-1];
foreach my $c (0..$L-1) {
next if $c == $$try[2] && !$same;
my $re = $last;
substr $re, $c, 1, '.';
my @new = grep /^$re/ && !$$try[1]{$_}, @words;
foreach my $new (@new) {
printf "\r%2d: %3d: %6d", 1+@{$$try[0]}, scalar @solutions
+,
++$tries if $verbose;
if ($new eq $end) {
push @solutions, [@{$$try[0]}, $end];
}
else {
next if $depth && @{$$try[0]} >= $depth-1;
push @tries, [[@{$$try[0]}, $new], {%{$$try[1]}, $new
+=> 1}, $c]
}
}
}
}
print "\n" if $verbose;
foreach my $solution (@solutions) {
print "@$solution\n";
}
__END__
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.