#!/usr/bin/perl -l

# Brute-force search algorithm to find word ladders.
# See Perl Quiz of the Week, http://perl.plover.com/qotw/

use strict;
use warnings;
use Getopt::Long;

our $DEBUG = 0;

GetOptions('debug|d' => \$DEBUG);

our ($START, $END, $DICT) = @ARGV;
$DICT ||= '/usr/share/dict/words';
for ($START,$END) { $_ ||= ''; $_ = lc; y/a-z//cd }

usage() unless $START and $END;
usage("words must be the same length")
    unless length($START) == length($END);

# read in dictionary

open(my $fh, $DICT) or die "can't read '$DICT': $!";
our @DICT = grep length($_) == length($END), map { chomp; lc } <$fh>;

# bail unless $END is in @DICT (it's OK if $START isn't in @DICT)

usage("both words must be in the dictionary")
    unless grep $END eq $_, @DICT;

# initialize %data

my %data;
$data{ $START } = { p => undef, k => [ get_kids($START) ], };

# algorithm: search all "kids" of the words currently in %data; repeat until
# either (a) the dictionary is exhausted, (b) no more untested children can be
# found, or (c) the solution is found

my $count = 0;

LOOP:
while (++$count && keys %data < @DICT) {
    #warn "iteration $count (@{[ scalar keys %data ]} words)\n";
    my @words = keys %data;
    my $tried = 0;
    foreach my $w (@words) {
        while ( @{ $data{ $w }{k} } ) {
            $tried++;
            my $k = shift @{ $data{ $w }{k} };
            $data{$k} ||= { p => $w, k => [ get_kids($k) ] };
            last LOOP if $data{ $END };
        }
    }
    last unless $tried;
}

if ($data{ $END }) {
    my @out = my $last = $END;
    while ($data{ $last }{p}) {
        unshift @out, $data{ $last }{p};
        $last = $data{ $last }{p};
    }
    print $_ for @out;
}
else {
    print "no path exists with this dictionary";
}

sub get_kids {
    return grep off_by_one($_[0],$_), @DICT;
}

# sub based on idea from Randy W. Sims in PQOTW mailing list
sub off_by_one {
    my $tmp = $_[0] ^ $_[1];
	return ($tmp =~ y/\0//c) == 1;
}

sub usage {
    die "@_\nusage: $0 [-d] word1 word2 [dictfile]\n";
}
