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

I also used an A* search, plus the %best hash which eliminates paths that
arrive at the same word.  Apologies for the messy code; I didn't get
around to tidying it up.

LP^>

#!/usr/bin/perl
use strict;
use warnings;

my $case = 0;

use Getopt::Long;
GetOptions( 'c!' => \$case,
          ) or die;

my $DEBUG = 0;

$? = 2;

my ($AAA, $BBB, $dic) = @ARGV;

die unless defined $AAA and $BBB;

$dic ||= "zcat Web2.gz |";

my $len = length($AAA);
die "$AAA and $BBB have different lengths" if $len != length($BBB);

for ($AAA, $BBB) { $_ = lc if $case }
my ($sawAAA, $sawBBB);

my %hash;

print "Reading words . . . ";
my $nwords = 0;
open WORDS, $dic or die;
while (<WORDS>)
{
  chop;
  next unless length == $len;
  $sawAAA++ if $_ eq $AAA;
  $sawBBB++ if $_ eq $BBB;
  $nwords++;
  $_ = lc if $case;

  foreach my $i (0 .. $len - 1)
  {
    my $pat = $_;
    substr $pat, $i, 1, '?';
    push @{$hash{$pat}}, $_;
  } 
}
close WORDS;
print " found $nwords words of $len letters.\n";

$sawAAA or die "$AAA not in dictionary";
$sawBBB or die "$BBB not in dictionary";

use Data::Dumper;
#print Data::Dumper->Dump([\%hash], ['*hash']);

while (my ($pat, $words) = each %hash)
{
  if (@$words == 1)
  {
    delete $hash{$pat};
  }
}

#print Data::Dumper->Dump([\%hash], ['*hash']);

sub min_dist
{
  my ($A, $B) = @_;

  my $X = "$A" ^ "$B";
  return $len - $X =~ tr/\0//;
}


my @queue;
$queue[ min_dist($AAA, $BBB) ] = [ [ $AAA ] ];

my %best;

while (1)
{
  $DEBUG and print Data::Dumper->Dump([\@queue], ['*queue']);

  use List::Util 'first';

  my $q = first { $queue[$_] and @{$queue[$_]} } 0 .. $#queue;

  unless (defined $q) { print STDERR "No path.\n"; exit 1 }

  my @path = @{pop @{$queue[$q]}};
  $DEBUG and print "path: @path\n";

  if ($path[0] eq $AAA and $path[-1] eq $BBB)
  {
    print "Path has @{[scalar @path]} words, inclusive:\n@path\n";
    exit 0;
  }

  my %seen = map { $_ => 1 } @path;
  $DEBUG and print Data::Dumper->Dump([\%seen], ['*seen']);

  my $last = $path[-1];
  my @pats = ($last) x $len;
  for (0 .. $len - 1) { substr($pats[$_], $_, 1) = '?' }
  $DEBUG and print Data::Dumper->Dump([\@pats], ['*pats']);
  
  my @next = grep { !$seen{$_} } map { @{$hash{$_} || []} } @pats;
  $DEBUG and print Data::Dumper->Dump([\@next], ['*next']);

  for (@next)
  {
    next if defined $best{$_} and $best{$_} <= @path;
    $best{$_} = @path;
 
    my $d = min_dist($BBB, $_) + @path - 1;
    push @{$queue[$d]}, [ @path, $_ ];
  }
}