Beefy Boxes and Bandwidth Generously Provided by pair Networks Joe
Think about Loose Coupling
 
PerlMonks  

Solve Word Ladders

by chipmunk (Parson)
on Jan 10, 2001 at 20:43 UTC ( #50934=sourcecode: print w/ replies, xml ) Need Help??

Category: Fun Stuff
Author/Contact Info Ronald J Kimball rjk@linguist.dartmouth.edu
Description: This script solves word ladders. A word ladder is a progression from one word to another, changing exactly one letter per step. Each intermediate step must also be a word. For example; dog cog cot cat.

An example of use:
% ladder perl monk 10 perl merl merk mirk mink monk
"merk"?? Let's find a better solution...
% ladder perl monk 10 merk perl perk peck pock mock monk
That works!

See the POD for more info.

(Updated to version 1.5; minor POD corrections only.)

#!/usr/local/bin/perl -w

# $Header: /usr/people/rjk/words/RCS/ladder.pl,v 1.5 2001/02/07 04:23:
+20 rjk Exp rjk $

use strict;

use vars qw($VERSION);
$VERSION = q$Revision: 1.5 $ =~ /Revision:\s*(\S*)/;

use Getopt::Std;

use vars qw($opt_w);

if (not getopts('w:') or @ARGV < 3 or $ARGV[2] =~ /\D/) {
    die <<EOT;
usage: $0 [-w <wordlist>] <word> <word> <max> [<bad word> ...]
EOT
}

my(@word, $max, @bad);

(@word[0, 1], $max, @bad) = @ARGV;

if (length $word[0] != length $word[1]) {
    die "Target words must be the same length.\n";
}

@bad = map { ($_, 0) } @bad;                 # for use in hash below

my $wordlist = $opt_w || 'wordlist';

open(WORDS, $wordlist) or die "Can't open $wordlist: $!\n";

my @wordlist;

while (<WORDS>) {                            # load word list into mem
+ory
    chomp;
    push @wordlist, $_
      if length $_ == length $word[0];
}
close(WORDS);


my @max = (int($max / 2) + ($max & 1), int($max / 2));
                                             # split $max in half;
                                             #   $max may be odd

my @queue = ([[$word[0]], 'break'], [[$word[1]], 'break']);
                                             # set up both halves of t
+he queue

my @words = ({$word[0] => [], @bad}, {$word[1] => [], @bad});
                                             # set up both halves of
                                             #  the word path array

my @solution;

my $p = 0;                                   # parity; which side of t
+he
                                             #   ladder is being exten
+ded


# find a solution, advancing one side of the ladder and then the other

STEP:
while (1) {

    my $cur = shift @{$queue[$p]};

    if (not $cur) {                          # all paths are dead-ends
+;
        last;                                #   give up
    }

    if ($cur eq 'break') {                   # no more paths to extend
        push @{$queue[$p]}, 'break' if @{$queue[$p]};
        $p ^= 1;                             # switch to other side of
+ ladder
        redo;
    }

    my $top = $cur->[-1];

    my @step = find_step($top);              # find all possible steps
                                             #   from the current word

    my $step;
    foreach $step (@step) {
        if ($words[$p ^ 1]{$step}) {
            @solution = (@$cur, $step, reverse @{$words[$p ^ 1]{$step}
+});
            last STEP;
        }

        next if defined $words[$p]{$step};   # skip words already in p
+ath
                                             #   and bad words

        next if @{$cur} == $max[$p];         # skip if path is at max 
+length

        $words[$p]{$step} = [@$cur];         # add this word to path
        
        push @{$queue[$p]}, [@$cur, $step];  # put extended path on th
+e queue

    }

}


if (@solution) {                             # found a solution!
    if ($solution[0] eq $word[1]) {          # print it, in desired or
+der
        @solution = reverse @solution;
    }
    print "@solution\n";
}

exit 0;


# find_step($word)
# returns a list of all the words in the word list
#   that differ from $word by one character
sub find_step {
    my $word = shift;

    my $re;

    $re = '^(?:';
    
    my $i;
    for ($i = 0; $i < length $word; ++$i) {
        my $tmp = $word;
        substr($tmp, $i, 1) = '.';
        $re .= $tmp . '|';
    }
    
    chop($re);
    
    $re .= ')$';

    
    $word =~ $re;                            # cache regex

    my @matches;

    for (@wordlist) {
        if (// and $_ ne $word) {
            push @matches, $_;
        }
    }
    
    return @matches;
}

__END__

=pod

=head1 NAME

B<ladder> -- find words which can be made from a string of letters

=head1 SYNOPSIS

B<ladder> [B<-w> I<wordlist>] I<start-word> I<end-word> I<max-length>
       [I<bad-word> ...]

=head1 DESCRIPTION

B<ladder> solves word ladders.  A word ladder is a progression from
one word to another, changing exactly one letter per step.  Each
intermediate step must also be a word.  For example; dog cog cot cat.

Given the start word, the end word, and the maximum allowed length,
B<ladder> will output a ladder between the two words.  B<ladder>
produces no output if it is unable to find a ladder within the maximum
length.  The start and stop word must be the same length.

A list of bad words may be specified after the other arguments.
B<ladder> will avoid using any of those words in the solution.

=head2 OPTIONS

B<ladder> accepts the following options:

=over 4

=item B<-w> I<wordlist>

By default, B<ladder> looks for a word file named 'wordlist' in the
same directory as the executable.  Use the B<-w> option to specify the
path to an alternate word list.

=back

=head1 FILES

=over 4

=item F<wordlist>

The list of words, found with the executable.

For a comprehensive word list, the author recommends the ENABLE word
list, with more than 172,000 words, which can be found at
http://personal.riverusers.com/~thegrendel/software.html

=back

=head1 BUGS

This implementation of B<ladder> has no known bugs.

=head1 AUTHOR

B<ladder> was written by Ronald J Kimball,
I<rjk@linguist.dartmouth.edu>.

=head1 COPYRIGHT and LICENSE

This program is copyright 2001 by Ronald J Kimball.

This program is free and open software.  You may use, modify, or
distribute this program (and any modified variants) in any way you
wish, provided you do not restrict others from doing the same.

=cut

Comment on Solve Word Ladders
Download Code
Re: Solve Word Ladders
by Lexicon (Chaplain) on Nov 24, 2001 at 15:40 UTC
    I'd like to suggest this bugfix. I downloaded ENABLE and unziped and all. But for some reason my perl (5.6.0 and 5.6.1 on Mandrake 8.0) wouldn't read that file properly. It kept cutting off the last character of the words. I'm a bit out of practice on my Perl, so I havn't deciphered the reason, but this fixed it for me.

    By the way, thanks a ton for this program. I'm writing a short story spoof of Alice based on word ladders for a class, and I need this program to produce lots of ladders for me. At least, if my idea pans out. Perhaps if the story is any good, I'll put up a link, though it will have little to do with Perl. ;)

    # This is around line 40 # Insert this where the second 'my @wordlist;' is declared. my @wordlist; while (<WORDS>) { $_ =~ /(\w*)/; $_ = $1; push @wordlist, $_ if length $_ == length $word[0]; } close (WORDS);

      I'm glad to hear that you've found this program useful!

      Regarding your bug report, it sounds like the word file has Windows line endings rather than Unix line endings. chomp removes the linefeed, but not the carriage return, screwing up the length of the line. Try removing carriage returns from the word file: perl -pi -e 'tr/\r//d' wordlist

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://50934]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others about the Monastery: (4)
As of 2014-04-21 01:40 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (489 votes), past polls