[SPOILER] Re: Perl 'Expert' Quiz-of-the-Week #22

Apologies for the delay, but a hectic travel schedule intervened.

My solution constructs trees searching from the source and target 
words until a common leaf word is found.  To restrict the number of 
words searched, I first construct what I call 'rings', lists of words 
that are n characters different from the source and target.

Put on your visualization caps here: imagine the source and target 
words sitting in a plane of words, and surrounded by concentric rings 
identifying the words that are 1, 2, ... letters different from each 
word.  We start the tree searches from the source and target with the 
1-rings as leaves.

Then at each step, we search nearby rings for words that are 1 letter 
different from the current leaf.  In general, if the leaf word is in 
ring n, these rings are n-1, n, and n+1.  (But we can be a bit more 
restrictive for rings 2 and lower.)  Having found a new leaf, we 
remove it from the ring so that it won't be searched again.

This was based on the observation that if a word was in ring n, then 
no word past ring n+1 could be only 1 letter different from that 
word.  (But that it might be necessary to retreat to an inner ring in 
order to find a path to an outer ring.)

Option -d specifies a dictionary (default /usr/share/dict/words) and 
-t will report the time.   Non-letters and case are ignored.  Takes 
~1 minute to solve ALGAE -> ZESTY and 20 minutes to solve HERPES -> 
OCTAVO, unless the dictionary lacks the necessary words, then it 
takes ~1 second.

Dictionary trivia: LOVE -> STOP is one step longer with ENABLE than 
my /usr/share/dict/words; for some reason the latter on OS X 10.2 
contains 'stot' whereas ENABLE does not.


#!/usr/local/bin/perl

# Solve the puzzle of turning one word into another by changing only one
# letter at a time, at each step making a valid word.

# Approach: search outward from source and target words, finding all
# words differing by one letter until search lists intersect.

use strict;
use warnings;
use Getopt::Std;

use constant SRC => 0;
use constant TRG => 1;

my ($Source, $Target, %Opt) = init();

my $Length = length($Source);
my $Dict   = read_dict($Opt{d}, $Length, $Source, $Target);

if (diff($Source, $Target, $Length) == 1)      # 2-step solution :-)
{
   printsol($Source, $Target);
}
else
{
   solve($Source, $Target, $Length, $Dict);
}

END { finish($Opt{t}) }


{
   my $Starting_Time;

   sub init
   {
     my $usage = "Usage: $0 [-t ] [-o] -d dict] source target\n";
     getopts('td:', \my %opt) or die $usage;

     my $source = shift @ARGV or die "No beginning word\n";
     my $target = shift @ARGV or die "No ending word\n";
     $opt{d} ||= '/usr/share/dict/words';

     if ($opt{t})
     {
       require Time::HiRes;
       $Starting_Time = Time::HiRes::time();
     }

     tr/a-zA-Z\000-\377/A-ZA-Z/d for ($source, $target);

     die $usage if @ARGV || (!$source) || (!$target);
     die "Words not same length\n" unless length($target) == length($source);
     die "Degenerate case\n" if $source eq $target;

     ($source, $target, %opt);
   }

   sub finish
   {
     if (shift)
     {
       printf "Took %.3f seconds\n", Time::HiRes::time() - $Starting_Time;
     }
   }
}


sub read_dict
{
   @ARGV = shift;
   my $length = shift;
   my ($source, $target) = @_;
   my @words;
   while (<>)
   {
     tr/a-zA-Z\000-\377/A-ZA-Z/d;
     next unless length == $length;
     push @words, $_ if $_ ne $source && $_ ne $target;
   }
   push @words, $source, $target;  # Make sure words are in dictionary
   \@words;
}


sub solve
{
   my ($source, $target, $length, $dict) = @_;

   my ($rings, $ring_of_word) = make_rings($length, $dict, $source, $target);

   my @pred;    # Predecessor chain
   my @leaves;  # Last words found in outward search

   $leaves[SRC]{$source}++;
   $leaves[TRG]{$target}++;

   while (1)
   {
     my $found;
     for my $what (SRC, TRG)
     {
       my $other = 1 - $what;

       # For each word in a current leaf, see which words in the
       # rings to search are 1 char away and make them the new leaves

       my %new_leaves;
       for my $word (keys %{ $leaves[$what] })
       {
	my $w_ring = $ring_of_word->[$what]{$word};
	my @near = near($word, $what, $length, $rings, $w_ring)
	  and $found = 1;

	# If any of the newly found words are in the other chain's
	# leaves, we have a solution

	$leaves[$other]{$_} and do_solution($_, $what, $word, @pred) for @near;

	$pred[$what]{$_} = $word for @near;
	$new_leaves{$_}++ for @near;
       }
       $leaves[$what] = \%new_leaves;
     }
     $found or die "No solution possible\n";
   }
}


sub do_solution
{
   my ($middle, $what, $word, @pred) = @_;

   # $middle is already in $other's predecessor chain
   # and has predecessor $word in $what's chain

   $pred[$what]{$middle} = $word;
   my @sol = $middle;
   my $front = my $back = $middle;
   my $again = 1;
   while ($again)
   {
     $again = 0;
     $front = $pred[TRG]{$front}, $again = 1, push    @sol, $front
       if $pred[TRG]{$front};
     $back = $pred[SRC]{$back},   $again = 1, unshift @sol, $back
       if $pred[SRC]{$back};
   }
   printsol(@sol);
}


sub make_rings
{
   my ($length, $dict, @inputs) = @_;
   my @rings;     # Number of letters difference from source or target
   my @ring_of_word;
   for my $word (@$dict)
   {
     for my $what (SRC, TRG)
     {
       my $ring = diff($inputs[$what], $word, $length);
       push @{ $rings[$what][$ring] }, $word;
       $ring_of_word[$what]{$word} = $ring;
     }
   }
   (\@rings, \@ring_of_word);
}


sub printsol
{
   print "Solution of length " . @_ . ":\n",
         join ("\n", @_), "\n\n";
   exit;
}


# Find words differing from the specified word by 1 letter;
# remove them from the rings so they aren't visited again
sub near
{
   my ($word, $what, $length, $rings, $this_ring) = @_;
   my @res;
   my @search_rings = rings_to_search($rings, $what, $this_ring);
   for my $ring (@search_rings)
   {
     $ring or next;
     my @words = @$ring;
     my @words_left;
     for (@words)
     {
       if (diff($word, $_, $length) == 1)
       {
	push @res, $_;
       }
       else
       {
	push @words_left, $_;
       }
     }
     @$ring = @words_left;
   }
   @res;
}


sub rings_to_search
{
   my ($rings, $what, $ring) = @_;
   my @nearby = nearby_rings($ring);
   map $rings->[$what][$_] => @nearby;
}


sub nearby_rings
{
   my $ring = shift;
   $ring == 0 and return 1;
   $ring == 1 and return (1, 2);
   $ring == 2 and return (2, 3);
   return ($ring - 1, $ring, $ring + 1);
}


# # chars difference between two words
sub diff
{
   my ($from, $to, $length) = @_;
   my $x = $from ^ $to;
   $length - ($x =~ tr/\000//);
}