#! /usr/bin/perl

use strict;
use warnings;
use Inline 'C';
use Getopt::Std;
no warnings 'recursion';

$| = 1;

our ($opt_v, $opt_l);

getopts('vl:');

if (@ARGV < 2) {
    die <<EOD;
usage: $0 [-v] [-l num] start end [dict]
    -v		be verbose
    -l num	use look-ahead of 'num' to determine whether order should be swapped
		if 'num' is -1, a supposedly sane look-ahead is used
EOD
}


my $start = shift;
my $end = shift;
my %words = read_wordlist(pop || "words");

delete $words{$start};
$words{$end} = ();

my ($swap, $cache) = lookahead($opt_l);

my @ladder;
if (not $swap) {
    @ladder = ladder($start, $end, \%words, [$start]);
} else {
    @ladder = reverse ladder($end, $start, \%words, [$end]);
}

if (@ladder) {
    #print "@ladder\n";
    print "$_\n" for @ladder;
    exit 0;
}
else {
    warn "\nNo ladder found\n";
    exit 1;
}

sub read_wordlist {
    my $file = shift;
    open my $fh, "<", $file or die "$file: $!\n";
    chomp (my @words = <$fh>);
    return map { lc, undef } grep length($_) == length($start), @words;
}


# find out which of $start and $end has fewer neighbours.
# 
# $depth:   1	- only direct neighbours
#	    2   - also neighbours of neighbours
#	    3   - also neighbours of neighbours of neighbours
#	    ...
#	   -1	- determine look-ahead based on word-length
#
# returns booleans indicating whether $start and $end should be swapped
sub lookahead {
    my $depth = shift;

    return if not $depth;
    
    if ($depth < 0) {
	$depth = int length($start) / 2;
    }

    # caches the neighbours for a word-pair
    # so that dist() further below wouldn't 
    # have to recalculate them
    my $cache;
    
    # words deleted from the dictionary:
    # those have to be added again once
    # the amount of neighbours has been calculated
    my @save;
   
    # counts of neighbours for $start => $end and
    # $end => $start
    my ($fwd_count, $bkw_count);
    
    my ($e, @cand) = ($end, $start);
    for (1 .. $depth) {
	my @c;
	for (@cand) {
	    push @save, $_;
	    delete $words{$_};
	    push @c, dist($_, $e, \%words);
	    $cache->{ $_, $e } = \@c;
	    $fwd_count += @c;
	}
	@cand = @c;
    }

    ($e, @cand) = ($start, $end);
    for (1 .. $depth) {
	my @c;
	for (@cand) {
	    push @save, $_;
	    delete $words{$_};
	    push @c, dist($_, $e, \%words);
	    $cache->{ $_, $e } = \@c;
	    $bkw_count += @c;
	}
	@cand = @c;
    }
    
    @words{@save} = ();
    return ($bkw_count < $fwd_count, $cache);
}

# find ladder leading from $s to $e
# 
# $words:   hash-reference of words in dictionary
#     $l:   array-ref being the current ladder
#     
# returns ladder as list or the empty list if no
# ladder exists.
sub ladder {
    my ($s, $e, $words, $l) = @_;
    
    return @$l if $s eq $e;

    my @candidates = dist($s, $e, $words) or return;
    delete @$words{ @candidates };
    print STDERR "@candidates\n" if $opt_v;
    for (@candidates) {
	push @$l, $_;
	if ((my @lad = ladder($_, $e, $words, $l))[-1] || "" eq $e) {
	    # a ladder was found
	    return @lad;
	}
    }
}

# returns a list of all neighbours of $s sorted by closedness to $e
sub dist {
    my ($s, $e, $words) = @_;
    my $mask = build_mask($s, $e);
    
    print "\r$s <=> $e: $mask " if $opt_v;
    return @{ delete $cache->{$s,$e}} if exists $cache->{$s, $e};

    my @cand = sort { ($a ^ $e) =~ tr/\0//c <=> ($b ^ $e) =~ tr/\0//c } 
    	       grep dist_one($s), grep pass_mask($mask), keys %$words;

    return @cand;
}

__END__
__C__

/* build mask for $_[0] and $_[1]:
 *  ('ladder', 'mother') would become result in '....er' */
char * build_mask (char *a, char *b) {
    char *mask = savepv(a);
    register char *m = mask;
    while (*m)
	if (*m++ != *b++) 
	    *(m-1) = '.';
    return mask;
}

/* returns boolean indicating whether $_ passes the mask
 * in $_[0] */
void pass_mask (char *mask) {
    Inline_Stack_Vars;
    register char *w = SvPVX(DEFSV);
    for ( ; *w; w++, mask++ ) {
	if (*mask != '.' && *mask != *w) 
	    XSRETURN_NO;
    }
    XSRETURN_YES;
}

/* $_[0] and $_ have a word distance of one */
void dist_one (char *a) {
    Inline_Stack_Vars;
    register char *b = SvPVX(DEFSV);
    register int count = 0;
    for ( ; *a; a++, b++) 
	count += (*a != *b);
    if (count == 1)
	XSRETURN_YES;
    XSRETURN_NO;
}
