#!/usr/local/bin/perl -l
# Colin Meyer cmeyer@helvella.org 2004-08-26

# true for on, false for off
my $CASE_SENSITIVE = 0;
my $DEBUG = 0;

# get stuff from command line
my $start = shift; $start = lc $start unless $CASE_SENSITIVE;
my $end   = shift; $end   = lc $end   unless $CASE_SENSITIVE;
my $DICT = shift;
$DICT ||= '/usr/share/dict/words';

my $size = length( $start );
die "different lengths: $start -> $end.\n" 
   unless $size == length( $end );

build_db( $size );

for ( $start, $end ) {
   die "$_ isn't in the dictionary" unless in_db( $_ ) 
}   

# take $start word. find all words that it morphs to. take $end word,
# do same. Any words in start list equal to end list? if so, we've found
# a solution (check for other solutions at this stage, report shortest).
# Otherwise reiterate, for each word in the lists. track words that have
# been visited, to avoid circles. if ever can't find any more words,
# then give up.

my ( $starts,     # possible paths from the starting word
     $ends,       # possible paths from the ending word
                  # see expand_paths for description of hashref structure
     @solutions,  
     $visited,    # tracks where we've been, so that we don't wander in circles 
     @joins       # track which word joined the start list to the end list
                  # just for curiosity (displayed when $DEBUG is true)
   );

# seed the data search structures
$starts->{ paths }{ $start }{ list } = [ $start ];
$ends  ->{ paths }{ $end   }{ list } = [ $end   ];
$starts->{ visited }{ $start }++;
$ends  ->{ visited }{ $ends  }++;

my $notdone = 1;
while ( $notdone ) {
   my $sc = expand_paths( $starts );
   my $ec = expand_paths( $ends   );

   die "no path!\n" unless ( $sc || $ec );

   # check to see if we've found the solution
   for my $leading_word ( keys %{ $starts->{ paths } } ) {
      if ( exists $ends->{ paths }{ $leading_word } ) {
         my @list;

         # the half of the solution from $start
         push @list, @{ $starts->{ paths }{ $leading_word }{ list } };

         # remove the duplicate, matching word
         push @joins, pop @{ $ends->{ paths }{ $leading_word }{ list } }; 

         # the half from $end
         push @list, reverse @{ $ends->{ paths }{ $leading_word }{ list } };

         push @solutions, \@list;
         $notdone = 0;
      }
   }
}

my $solution = shift @solutions;
for ( @solutions ) {
   $solution = $_ if @$solution > @$_
} 

print for @$solution;
#print scalar( @$solution ), " steps";

END {
  if ( $DEBUG ) {
    require 'YAML.pm'; 
    print "### Joining Words: @joins";
    print YAML::Dump( \@solutions );
    print "### STARTS";
    print YAML::Dump( $starts );
    print "### ENDS";
    print YAML::Dump( $ends );
  }
}


# passed in a hashref
# $h keys are: 
# visited - a hash whose keys are words that have already been seen here
# paths   - a hash whose keys are the leading word of a path, and whose
#           values are a hash with keys: 
#   beenseen - a marker so that each list is only expanded once
#   list     - an arrayref of the path that lead up to this word
# (either by the start search paths, or the end search paths, as the program
#  above uses it)
#
# action is to take each path and create new paths, each one expanded to
# one level more morphed, if the resulting word that hasn't yet been
# visited. adds these new paths directly back to the hashref that's
# passed in.
#
# returns a count of how many new paths were created
#
sub expand_paths {
   my $h = shift;
   my $c = 0;
   WORD:
   for my $word ( keys %{ $h->{ paths } } ) {
      next WORD if $h->{ paths }{ $word }{ beenseen }++;
      for my $nextword ( grep ! $h->{ visited }{ $_ }++, morph( $word ) ) {
         $c++;
         $h->{ paths }{ $nextword }{ list } = 
               [ @{ $h->{ paths }{ $word }{ list } }, $nextword ];
      }
   }
   return $c;
}


# database consists of two hashes, %word2rung and %rung2word each word
# has l rungs, where l is its length. a rung is the word with one of
# its letters removed. the rungs are ordered by which letter was dropped
# any word morphs into another word if it has a matching rung (in the same
# position).
{
   my ( %word2rung, %rung2word, @words, $SIZE );

   sub build_db {
      $SIZE = shift;

      open DICT, '<', $DICT or die "can't open $DICT: $!";
      @words = grep length( $_ ) == $SIZE, 
               map { chomp; $CASE_SENSITIVE ? $_ : lc $_ } <DICT>;
      close DICT;

      for my $w ( @words ) {
         my @rungs = _rungs( $w );
         $word2rung{ $w } = \@rungs;
         my $pos = 0;
         for my $rung ( @rungs ) {
            push @{ $rung2word{ $rung }[ $pos++ ] }, $w;
         }
      }
   }
   
   sub _rungs {
      my $w = shift;
      return map { my $c = $w; substr( $c, $_, 1 ) = ''; $c } 0..($SIZE-1);
   }
   
   sub in_db {
      return grep( /$_[0]/, @words );
   }
   
   sub morph {
      my $w = shift;
      my @steps; my $pos = 0;
      for my $rung ( @{ $word2rung{ $w } } ) {
         push @steps, @{ $rung2word{ $rung }[ $pos++ ] };
      }
      return grep $_ ne $w, @steps;
   }
}
