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

# $Header: /usr/home/rjk/words/RCS/ladder.pl,v 1.9 2004/08/30 03:24:49 rjk Exp rjk $

use strict;

use vars qw($VERSION);
$VERSION = q$Revision: 1.9 $ =~ /Revision:\s*(\S*)/;

use Getopt::Std;

use vars qw($opt_w $opt_a);

if (not getopts('w:a') or @ARGV < 2) {
  die <<EOT;
usage: $0 [-w <wordlist>] [-a] <word> <word> [<bad word> ...]
EOT
}

my @word = splice @ARGV, 0, 2;
$opt_w = shift;

my @bad = @ARGV;

if (length $word[0] != length $word[1]) {
  die "Target words must be the same length.\n";
}

@bad = map { ($_, 0) } @bad;                 # for use in hash below

my $wordlist = $opt_w || 'wordlist';

open(WORDS, $wordlist) or die "Can't open $wordlist: $!\n";

my @wordlist;

while (<WORDS>) {                            # load word list into memory
  chomp;
  push @wordlist, lc $_
    if length $_ == length $word[0];
}
close(WORDS);


my @queue = ([[$word[0]], 'break'], [[$word[1]], 'break']);
                                             # set up both halves of the queue

my @words = ({$word[0] => [], @bad}, {$word[1] => [], @bad});
                                             # set up both halves of
                                             #  the word path array

my @solutions;

my $p = 0;                                   # parity; which side of the
                                             #   ladder is being extended


# find a solution, advancing one side of the ladder and then the other

STEP:
while (1) {

  my $cur = shift @{$queue[$p]};

  if (not $cur) {                            # all paths are dead-ends;
    last;                                    #   give up
  }

  if ($cur eq 'break') {                     # no more paths to extend
    last if @solutions;                      # no more solutions at this length

    push @{$queue[$p]}, 'break' if @{$queue[$p]};

    if (@{$queue[$p^1]} <= @{$queue[$p]}) {
      $p ^= 1;                               # switch to other side of ladder
    }                                        #   if it has fewer steps

    redo;
  }

  my $top = $cur->[-1];

  my @step = find_step($top);                # find all possible steps
                                             #   from the current word

  my $step;
  foreach $step (@step) {
    if ($words[$p ^ 1]{$step}) {
      push @solutions, [@$cur, $step, reverse @{$words[$p ^ 1]{$step}}];
      last STEP unless $opt_a;               # stop unless looking for all
                                             #  solutions of this length
    }

    next if defined $words[$p]{$step};       # skip words already in path
                                             #   and bad words

    $words[$p]{$step} = [@$cur];             # add this word to path
        
    push @{$queue[$p]}, [@$cur, $step];      # put extended path on the queue

  }

}


foreach my $solution (@solutions) {          # for each solution found, if any
  if ($solution->[0] eq $word[1]) {          # print solution, in desired order
    $solution = [ reverse @$solution ];
  }
  print "$_\n" for @$solution;
  print "\n" if @solutions > 1;
}

if (not @solutions) {
  die "Can't find a solution for $word[0] - $word[1].\n";
}

exit 0;


# find_step($word)
# returns a list of all the words in the word list
#   that differ from $word by one character
sub find_step {
  my $word = shift;

  my $re;

  $re = '^(?:';

  $re .= join '|', map { substr(my $tmp = $word, $_, 1, '.'); $tmp }
                       0 .. length($word) - 1;
    
  $re .= ')$';

    
  $word =~ $re;                            # cache regex

  my @matches;

  for (@wordlist) {
    if (// and $_ ne $word) {
      push @matches, $_;
    }
  }

  return @matches;
}
