#!/usr/bin/perl

use Getopt::Long;
use Time::HiRes qw(time);
use warnings;
use strict;

use vars qw(%words $start $target %visited
            @workqueue1 @workqueue2
            $workqueue_dirty1 $workqueue_dirty2
            $verbose %path $oneway );

my $usage = "$0 [ -d dictionary ] [ -c ] [ -v ] [ -1 ] fromword toword";

my $dictionary = './Web2';
my $casesensitive = 0;
$verbose = 0;
$oneway = 0;
GetOptions("dictionary|d=s" => \$dictionary,
           "case|c" => \$casesensitive,
           "verbose|v+" => \$verbose,
           "1" => \$oneway) or die($usage);
$start = shift or die($usage);
$target = shift or die($usage);
$dictionary = shift;
@ARGV and die($usage);
length($target) == length($start) or
  die "'$target' and '$start' must be of the same length";

$target = lc($target) unless $casesensitive;
$start = lc($start) unless $casesensitive;

my ($dstart) = time;

my $tlen = length($target);
my ($foundstart, $foundtarget) = (0,0);
open(DICT, '<', $dictionary) or die "Couldn't open $dictionary: $!";
%words=();
while(my $word = <DICT>) {
  chomp($word);
  next unless (length($word)==$tlen);
  $word=lc $word unless $casesensitive;
  $foundtarget = 1 if ($word eq $target);
  $foundstart = 1 if ($word eq $start);
  $words{$word} = 1;
}

my $dend = time;

printf STDERR '%f seconds for dictionary load%s', $dend - $dstart, "\n"
  if $verbose;
printf STDERR '%d active words%s', scalar(keys %words), "\n"
  if $verbose;

$foundstart or die "$start not in dictionary";
$foundtarget or die "$target not in dictionary";

# The preceding code should have been obvious - read options, build
# the %words hash, etc.  Here then follow a bunch of subroutines
# that I use in MAIN, below.
#
# dist_to_target   - number of characters where $_[0] and $target differ
# dist_to_start    - ditto for $start
# qput - put a word onto one of my priority queues
# qget - get a word from one of the priority queues
# neighbors - get a list of the valid neighbors of a given word


# Yeah, I got hooked on building "perl macros" with the last QOTW

*dist_to_target =
  eval('sub { ' .
       join(" + ",
            map { sprintf '(substr($_[0],%d,1) ne q[%s])',
                    $_, quotemeta(substr($target,$_,1)); } (0..$tlen-1)) .
       ' }');

*dist_to_start =
  eval('sub { ' .
       join(" + ",
            map { sprintf '(substr($_[0],%d,1) ne q[%s])',
                    $_, quotemeta(substr($start,$_,1)); } (0..$tlen-1)) .
       ' }');

# returns lsofar, direction, word
sub qget () {
  if (!@workqueue1 or !@workqueue2) {return qw[];}

  @workqueue1 = sort @workqueue1 if $workqueue_dirty1;
  @workqueue2 = sort @workqueue2 if $workqueue_dirty2;
  $workqueue_dirty1=$workqueue_dirty2=0;

  my ($direction, $l, $w);
  if (@workqueue1 < @workqueue2 or $oneway) {
    ($l, $w) = unpack("x[N] N Z*", shift @workqueue1);
    $direction = 1;
  } else {
    ($l, $w) = unpack("x[N] N Z*", shift @workqueue2);
    $direction = -1;
  }
  ($l,$direction,$w);
}

sub qput ($$$) {
  my ($lsofar, $direction, $word) = @_;
  my ($d) = ($direction>0) ?
    dist_to_target($word) : dist_to_start($word);
  if ($direction > 0) {
    unshift @workqueue1, pack("N N Z*", $lsofar + $d, $lsofar, $word);
    $workqueue_dirty1=1;
  } else {
    unshift @workqueue2, pack("N N Z*", $lsofar + $d, $lsofar, $word);
    $workqueue_dirty2=1;
  }
}

sub neighbors ($) {
  my $word = $_[0];
  grep($word ne $_,
       map {
         my $pre=substr($word,0,$_);
         my $post=substr($word,$_+1);
         grep($words{$_},
              map {$pre . $_ . $post} ('a'..'z'))
       } (0..$tlen-1));
}

# MAIN code

# check one annoying edge case:

if ($start eq $target) {
  print "$start\n";
  exit(0);
}

%visited=($start => 1, $target => -1);
%path=();
@workqueue1=@workqueue2=();

my $searchstart = time;
printf STDERR '%f seconds miscellaneous setup%s', $searchstart - $dend, "\n"
  if $verbose;

qput(0,1,$start);
qput(0,-1,$target);

my ($lsofar, $dir, $word);

END { printf STDERR '%f seconds search time%s', time - $searchstart, "\n"
        if $verbose; }

while (($lsofar, $dir, $word) = qget) {
  print STDERR "Working with $word (after $lsofar steps)\n" if $verbose>1;
  for my $neighbor (neighbors($word)) {
    if ($visited{$neighbor}) {
      if ($visited{$neighbor} != $dir) {
        # Found it, now make the list
        my ($tostart, $totarget) = ($word, $neighbor);
        if ($dir < 0) {($tostart, $totarget) = ($neighbor, $word);}
        my @list = ();
        while ($tostart) {
          unshift @list, $tostart;
          $tostart = $path{$tostart};
        }
        while ($totarget) {
          push @list, $totarget;
          $totarget = $path{$totarget};
        }
        print "$_\n" for @list;
        exit(0);
      } else {
        next;
      }
    }
    $visited{$neighbor} = $dir;
    $path{$neighbor} = $word;
    qput($lsofar+1, $dir, $neighbor);
  }
}

print STDERR "No path exists in dictionary between $start and $target\n";
exit(1);
