Solving a Brain Teaser with word lists and Perl

I'm a programmer. When I see a problem, I get tempted to code the solution. One place where this temptation comes into play is brain teaser problems. Once, a while ago, a radio show had a brain teaster where you take the phrase PRECHRISTMAS SALE, turn it into a 4x4 block and find the longest word you can without reusing a letter. I used Perl and found six eight-letter words.

And, of course I used my powers on Sudoku.

Now, I've seen a problem that's inspired me again.

By changing one letter at a time to form different English words, and leaving all other letters in their original positions, convert SIXTH into TENTH in the fewest steps possible. Good luck!

S I X T H
_ _ _ _ _
_ _ _ _ _
_ _ _ _ _
_ _ _ _ _
_ _ _ _ _
_ _ _ _ _
T E N T H

There are Spoilers below

As I learned with PRECHRISTMASSALE, which I've since found is Boggle, if you're going to find words, you first need to know words. So, I pulled and adapted my Boggle code for coming up with a dictionary list.

sub dictionary {
    my ( $length ) = @_ ;
    my %done ;
    my %word ;
    my $dir = './Dict' ;
    my $dirhandle ;
    opendir $dirhandle, $dir ;
    my $file ;
    while ( defined( $file = readdir $dirhandle ) ) {
        next if $file =~ m(^\.)mx ;
        open my $filehandle, '<', $dir . q{/} . $file ;
        while ( <$filehandle> ) {
            chomp ;
            $_ = lc $_ ;
            next if $done{ $_ }++ ;
            next if length != $length ;
            $word{ $_ }++ ;
            }
        close $filehandle ;
        }
    closedir $dirhandle ;
    return sort { $a cmp $b } keys %word ;
    }

Of course, you need to be in the same directory as a directory full of dictionaries. I used a few I pulled from the CERIAS FTP site, and probably has some overlap, but better that then missing a word and thus a connection.

I then started poking at the words, trying to find the next. I came up with a way to get all the proper alternatives, given a word. I then pulled it into a subroutine.

sub get_word_choices {
    my ( $word ) = shift ;
    my @word = split m{}mx, $word ;
    my @output ;
    for my $pos ( 0 .. scalar @word - 1 ) {
        my @local = @word ;
        $local[ $pos ] = '.' ;
        my $local = join '', @local ;
        my @words = grep { m{$local}mx } grep { !m{$word}mx } @dictionary ;
        next if scalar @words == 0 ;
        push @output , @words ;
        }
    return @output ;
    }

I should probably pass @dictionary rather than leave it as a global, but certainly, you don't want to re-parse the dictionary file each time.

It struck me about this point that I should have all I need to automatically solve this, not leaving me to use this tool to piece something together.

I am not as happy with this part as I could be.

sub check_words {
    my $word2 = shift ;
    my @words = @_ ;
    return if scalar @words > 7 ;
    my $last = $words[-1] ;
    if ( $last eq $word2 ) {
        say '' ;
        say join ' ' , @words , scalar @words ;
        }
    my @choices = get_word_choices( $last ) ;
    #say join ' ' , @words ;
    for my $choice ( @choices ) {
        next if grep { m{$choice}mx } @words ;
        check_words( $word2 , @words , $choice ) ;
        }
    print join ' ' ,  '' , scalar @words ;
    return ;
    }

It's depth-first search and it's long. Which, I suppose, is unavoidable for depth-first search. Consider this solution:

sixth
sixte
sixty
silty
tilty
tinty
tenty
tenth 

sixth to sixty is just as legal a jump as sixth to sixte. If I used an iterative process with a better data structure, I could use a shortest path algorithm and bypass sixte. And, of course, by putting print to give me some appreciation of progress, I'm bogging the thing way down. So, that's where I'd rewrite to make this better.