[SPOILER] Solution to Perl 'Expert' Quiz-of-the-Week #22

Here's my try; alternately builds a list of words at progressively
longer distances from the beginning and ending words.  Dictionary
load time is a little slow for longer words; at some point it would
be more efficient to have the %climb hash be keyed by actual source
words, not by templates with . in place of one letter.


use strict;
use warnings;

@ARGV < 2 || @ARGV > 3 and die "usage: wordladder word1 word2\n";

my ($left, $right, $dict) = @ARGV;
$dict = "Web2" if !defined $dict;

my $len = length($left);
length($right) == $len or die "words must have equal length\n";

if ($left ne lc $left || $right ne lc $right) {
    warn "wordladder is case insensitive\n";
    $left = lc $left;
    $right = lc $right;
}

# $left and $right aren't actually required to be in the dictionary,
# just any intermediate words; however, "bar" to "baz" requires an
# intermediate step "bap" if neither "bar" nor "baz" is in the
# dictionary.  This may be construed as a bug.

# %climb shows which words can be reached from a given
# template. E.g. $climb{"l.ve"} = [qw/lave live love/]
# For the provided dictionaries, this scales fairly well
# for any word length, though load time and memory use
# are larger for some lengths.

my %climb;
load_dict($len, \%climb);

# alternate adding words to %left and %right; the values
# represent the originating word.  @newleft and @newright
# are the most recently added words.  $join is set once
# the left and right word sets intersect.

my ($join, %left, %right, @newleft, @newright);

$right{$right} = "";
@newright = $right;
$left{$left} = "";
@newleft = $left;

while (1) {
    ($join) = grep exists $right{$_}, @newleft and last;
    @newleft = expand(\@newleft, \%left, \%climb) or last;
    
    ($join) = grep exists $left{$_}, @newright and last;
    @newright = expand(\@newright, \%right, \%climb) or last;
}

show_ladder($join, \%left, \%right);
exit 0;

sub load_dict {
    my ($len, $climb) = @_;

    open my $dict_fh, "< $dict" or die "Couldn't open dictionary $dict: $!\n";
    while (my $word = <$dict_fh>) {
        # blithely assume last line correctly has newline
        if (length($word) == $len+1) {
           chomp($word = lc $word);

           # include this word in the list for each template that matches
           push @{$climb->{"$`.$'"}}, $word while $word =~ /./g;
        }
    }
}

sub show_ladder {
    my ($join, $lladder, $rladder) = @_;

    if (defined $join) {
        my @ladder = $join;

        # trace back to the beginning word
        my $left = $join;
        while (length($left = $lladder->{$left})) { unshift @ladder, $left }

        # and forward to the ending word
        my $right = $join;
        while (length($right = $rladder->{$right})) { push @ladder, $right }

        print "$_\n" for @ladder;
    } else {
        die "No solution found!\n";
    }
}

sub expand {
    my ($old, $ladder, $climb) = @_;

    my %climb;

    # for each word in the old most-recently-found list,
    # generate each possible template and add any words
    # for those templates (incidentally filtering duplicates)
    for my $word (@$old) {
        while ($word =~ /./g) {
            my $add = $climb->{"$`.$'"} or next;
            @climb{@$add} = ($word) x @$add;
        }
    }

    # filter out any words already found on this side
    my @new = grep !exists $ladder->{$_}, keys %climb;
    @$ladder{@new} = @climb{@new};
    @new;
}