#!/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/dict/words)
            'depth=s',       \$depth,      # Max depth (0 means infinite)
            'verbose=i',     \$verbose,    # Print progess
            'same',          \$same,       # If set, allow the same letter
                                           # to be changed in succession.
);
$| = 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 the
# 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__