#!/usr/bin/perl -w

use strict;

my $Usage = <<USAGE;

Usage: $0 word1 word2 [dictionary_file]

This script performs a breadth-first search to find
all possible shortest solutions (modulo anagrams) to an
anagram word ladder.
All the solutions are printed out at the end.
Since the search is exhaustive, it can be quite slow
for longer words.
The dictionary file defaults to 'scrabble.txt'

EXAMPLE:
> perl $0 BAD PUN
BAD DAP NAP PUN
BAD BUD PUB PUN
BAD DAP DUP PUN
BAD BUD BUN PUN
BAD BUD DUN PUN
BAD AND NAP PUN
USAGE

die $Usage unless $ARGV[1];

my $word1 = $ARGV[0];
my $word2 = $ARGV[1];

my $dict_file = $ARGV[2] ? $ARGV[2] : 'scrabble.txt';

die "$0: words must be the same length" unless length($word1) == length($word2);
my $len = length($word1);

my $dict = create_hash($dict_file);

# We only care about words of the appropriate length
$dict = $dict->{$len};

my $num1 = word2num($word1);
my $num2 = word2num($word2);
# Make sure these are both acceptable words
#unless (exists($dict->{$num1})) {die "$0: the word $word1 does not exist.";}
unless (exists($dict->{$num2})) {die "$0: the word $word2 does not exist.";}

#print join(' ',@{$dict->{word2num($word1)}});
#print "\n";
#print num2word($num1)."\n";

# Initialize tree
my %tree;
my $ret = find_ladder(\%tree,0,$word1,$word2,$dict);

foreach my $aref (@$ret)
{
    foreach my $num (@$aref){print $dict->{$num}->[0]." ";}
    print "\n";
}

######
# SUBS
######

sub find_ladder
{
    my ($tree,$level,$word1,$word2,$dict) = @_;

    my @return_array;
    my $num2 = word2num($word2);

    #print "$level\n";

    if ($level >= 3 * length($word1)) {return \@return_array;}

    if ($level == 0)
    {
        @{$tree->{0}->{$word1}} = ($num1);
        #print  "@{$tree->{0}->{$word1}}\n";
        return find_ladder($tree,1,$word1,$word2,$dict);
    }
    else
    {
        my $h = $tree->{$level - 1};
        # Go through each word
        foreach my $w (keys %{$h})
        {
            #print "$w\n";
            # Get the sequence in the tree leading up to this point
            my @seq = @{$h->{$w}};
            # Go through each letter of the word
            for (my $i=0; $i<length($w); $i++)
            {
                my $l = substr($w,$i,1);
                # Replace each letter with a different letter of the alphabet
                # If the result can be anagrammed into a real word, tack it on to the list.
                foreach my $let (qw/A B C D E F G H I J K L M N O P Q R S T U V W X Y Z/)
                {
                    # Don't add the same letter
                    next if $let eq $l;
                    my $w2 = $w;
                    # Replace
                    substr($w2,$i,1) = $let;

                    # Check for existence
                    my $num = word2num($w2);
                    if (exists($dict->{$num}))
                    {
                        #print "  $w2\n";
                        my @arr = @seq;
                        push(@arr,$num);
                        @{$tree->{$level}->{$w2}} = @arr;
                        # Check to see if we've gotten our final word
                        if ($num == $num2) { push(@return_array,[@arr]); }
                    }
                }
            }
        }
    }
    if (@return_array) {return \@return_array;}
    else {return find_ladder($tree,$level+1,$word1,$word2,$dict);}
}

sub create_hash
{
    my $dict = shift; # Filename of scrabble dictionary
    # Create a hash from the scrabble dictionary
    my %hash = ();
    open SCRAB, $dict or die $!;
    while (<SCRAB>)
    {
        chomp;
        my $w = uc $_;
        my $l = length($w);
        push(@{$hash{$l}{word2num($w)}},$w);
    }
    return \%hash;
}

sub num2word
{
    # Given an integer, return its class (i.e. a sorted list of the letters it represents)
    # Note: this is not actually used in the code.
    my $n = shift;
    my $w = '';
    my %conv = qw(2 A 3 B 5 C 7 D 11 E 13 F 17 G 19 H 23 I 29 J 31 K 37 L 41 M 43 N 47 O 53 P 59 Q 61 R 67 S 71 T 73 U 79 V 83 W 89 X 97 Y 101 Z);
    my @primes = sort {$a <=> $b} keys %conv;
    my $ctr = 0;
    while ($n > 1)
    {
        while ($ctr < 26)
        {
            if ($n % $primes[$ctr] == 0)
            {
                #print $primes[$ctr]."\n";
                $w .= $conv{$primes[$ctr]};
                $n = $n / $primes[$ctr];
                $ctr = 26;
            }
            $ctr++;
        }
        $ctr = 0;
        #print "$n\n";
    }
    return $w;
}

sub word2num
{
    # Given a word, turn it into an order-independent hash
    # Convert the word to ALL CAPS
    my $w = uc shift;
    # Remove any non-alphas
    $w =~ s/[^A-Z]//g;
    my %convert = qw(A 2 B 3 C 5 D 7 E 11 F 13 G 17 H 19 I 23 J 29 K 31 L 37 M 41 N 43 O 47 P 53 Q 59 R 61 S 67 T 71 U 73 V 79 W 83 X 89 Y 97 Z 101);
    my $val = 1;
    foreach my $l (split(//,$w))
    {
        $val *= $convert{$l};
    }
    return $val;
}