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

And another solution. Bog standard breadth-first search, I think. (Although I
really ought to look these things up before saying that.)

Innovation resides in programmer lazyness (use of String::Approx for identi-
fying words with an edit distance of 1.) Which makes this solution slow com-
pared to most of the others, but that's fine by me.

Original version of this program computed the full network of neighbouring
words before starting to walk the graph. That was nice for studying the net-
work, but lousy for running time. Although, octavo->herpes was just about as
fast as worship->justice :/ - both about 11 minutes.


#!/usr/bin/perl -w -l

use strict;
use String::Approx 'amatch';

my $VERBOSE=1;
die "Usage: $0 startword endword <dictionaryfile>\n" if @ARGV<2 or @ARGV>3;
my ($from, $to, $dict) = @ARGV;
$dict ||= "Web2.txt";

my $l = length($from);
die "Unequal word lengths\n" unless length($to) == $l;
die "Identical start- and endwords\n" if $from eq $to;

open DICT, $dict or die "Couldn't open dictionary file for reading: $!\n";

my %words;
for (<DICT>,$from,$to)
{
        chomp;
        $words{lc $_} = 1 if length==$l;
}

my %parent; # traces shortest path
my @stack;
my $iter = 0;
push @stack, $from;
push @stack, "ITERATION " if $VERBOSE;
$parent{$from} = 'MARKER'; # must reread algorithm - look for more elegant
solution
$parent{MARKER} = $to;
delete $words{$from};

BFS: while (my $node = shift @stack)
{
        if ($VERBOSE and $node eq "ITERATION ")
        {
                last unless @stack;
                warn "$node ".++$iter." | #stack ".(scalar @stack)." |
@stack\n";
                push @stack, "ITERATION ";
                next;
        }
        for my $child (amatch($node,["S1","I0","D0"],keys %words))
        {
                next if exists $parent{$child};
                delete $words{$child};
                $parent{$child} = $node;
                last BFS if $child eq $to;
                push @stack, $child;
        }
}

die "No path found\n" unless exists $parent{$to};

my @trace;
my $node = 'MARKER';
while ($node = $parent{$node})
{
        last if $node eq 'MARKER';
        push @trace, $node;
}
print join "\n", reverse @trace;
__END__

--
Jurgen Pletinckx
AlgoNomics NV