#!/usr/bin/perl

use warnings;
use strict;

my ($first, $last, $wordlist) = @ARGV;
$wordlist = $wordlist || './words';
die "First and last words must be the same length.\n" 
    unless length($first) == length($last);

if ($first eq $last){
    print "Identicle words, very short ladder.\n";
    exit 1;
}

$wordlist = trim_wordlist($wordlist, $first);

if (my $ladder = build_rung([$first], $last, $wordlist)){
    # print our ladder
    push(@$ladder, $last);
    $ladder = compress($ladder);
    print "$_\n" for @$ladder;
} else {
    print "No ladder found!\n";
    exit 1;
}


# subs
sub trim_wordlist{
    my ($wordlist, $first) = @_;
    my $return_list;
    open(F, '<', $wordlist) || die "cannot open wordlist: $wordlist $!\n";
    my $length = length($first);
    while (<F>){
	chomp;
	if (length == $length){
	    push(@$return_list, lc($_));
	}
    }

    return $return_list;
}

sub build_rung{
    # build the next step of our ladder :)
    my ($curr_ladder, $last, $wordlist) = @_;

    my $next_words = get_next_words($curr_ladder, $wordlist, $last);
    return $curr_ladder if grep(/$last/, @$next_words);

    foreach my $word (@$next_words){
	push(@$curr_ladder, $word);
	return $curr_ladder if build_rung($curr_ladder, $last, $wordlist);
	pop(@$curr_ladder);
    }

    return 0;
}

sub build_re{
    # create regex string used to find the next set of words
    my ($ladder, $last) = @_;
    my $word = $ladder->[-1];

    my ($yes_re, $no_re);
    my @chars = split(//, $word);
    my @last_chars = split(//, $last);

    for (my $i=0; $i < @chars; $i++){
	my @curr = @chars;
	$curr[$i] = '.' unless $curr[$i] eq $last_chars[$i];
	$yes_re .= join('', @curr);
	$yes_re .= '|'	if $i < @chars - 1;
    }

    for (my $i=0; $i < @$ladder; $i++){
	$no_re .= $ladder->[$i];
	$no_re .= '|' if $i < @$ladder - 1;
    }

    return ($yes_re, $no_re);
}

sub get_next_words{
    # retrieve the next set of words for the current rung
    my ($curr_ladder, $wordlist, $last) = @_;

    my ($yes_re, $no_re) = build_re($curr_ladder, $last);
    my @list = grep(/$yes_re/ && ! /$no_re/, @$wordlist);

    # sort words closest by proximity to last word
    my $last_chars = [split(//, $last)];
    @list = sort {
	index_variant($b, $last_chars) <=> index_variant($a, $last_chars)
	} @list;
    return \@list;    
}

sub index_variant{
    # return the number of letter positions in $word that match @$last_chars
    my ($word, $last_chars) = @_;

    my @word_chars = split(//, $word);
    my $index = 0;
    for (my $i=0; $i < @$last_chars; $i++){
	$index++ if $word_chars[$i] eq $last_chars->[$i];
    }
    
    return $index;
}

sub compress{
    my $list = shift;
    
    my $length = length($list->[0]) - 1;
    my $i_length = @$list;
    for (my $i=0; $i < $i_length; $i++){
	my $curr_word_chars = [split(//, $list->[$i])];

	for (my $j = @$list - 1; $j > $i + 1; $j--){
	    if (index_variant($list->[$j], $curr_word_chars) == $length){
		# we can compress everthing in between words i and j
		splice(@$list, $i + 1, $j - $i - 1);
		my $shrink =  $j - $i -1;
		$i_length -= $shrink; $j -= $shrink;
	    }
	}
    }

    return $list;
}
