Re: Perl 'Expert' Quiz-of-the-Week #22 - Long ladders

You know, I don't think that anyone has mentioned in this discussion
that pragdave (http://pragprog.com/pragdave/) had this problem as one
of his "Code Katas" several months ago.  I admit that my perl solution
was based on a ruby solution I'd written up in response to that kata.
(Which can be found at http://snowplow.org/martin/katas/kata19.rb )

"Jurgen Pletinckx" <[email protected]> writes:

> I played around a bit more with BFS. Here are 
> some of the longest ladders - might come in 
> handy for timings, stress tests and compari-
> sons. (Of course, I should have mailed these 
> last week to be actually useful.)

If you care for independent confirmation, I got the same ladder
lengths for the same length words.

> Webster2
>
> 17 steps: idol -> upas
Also: obol -> upas

> 37 steps: alure -> yasht
This is the only one this long

> 54 steps: peltry -> zounds
This is the only one this long

> 40 steps: cortina -> turjite
Also: cortina -> turfite

> 37 steps: deadness -> thusness
Also: deafness -> thusness

> (for longer word lengths, the ladders become very 
> boring indeed. indefectibly -> undelectably ?)
They get really boring around length 20.

> words
>
> 20 steps: inca -> ursa
Also: usra -> veto  (but inca->veto is a simple 8 steps)

> 47 steps: agway -> troop
The only one for length 5, though in "words" the 
6 letter ladders were interesting:

 dobbin -> doodle, dobbin -> noodle, dobbin -> poodle,
 dobbin -> tootle, doodle -> robbin, noodle -> robbin,
 poodle -> robbin, robbin -> tootle

all at 25 words each.

> wordnet
>
> 34 steps: array -> rosid
Also: array -> devon, array -> demob, array -> lemon, 
      array -> robin and array -> eosin
> 47 steps: limply -> trusty
The only one for this length.

Here's the unrefined code that computes this; it takes an argument
that is the word length and then reads the dictionary through <> (so
redirect in the dictionary, or put several on the command line to use
the union)

#! /usr/bin/perl -w

use Time::HiRes qw(time);
use strict;
use vars qw(%maxPossible $len %words);

my $start = time;
$len = shift;

my %sig2words=();
while (<>) {
  chomp;
  next unless length==$len;
  next unless /^[a-z]+$/;
  my $w=lc; # use my $w=$_; for case-sensitive
  my @sigs=map {$a=$w; substr($a,$_,1)='_';$a;} (0..$len-1);
  for my $sig (@sigs) {
    $sig2words{$sig} ||= [];
    push @{$sig2words{$sig}}, $w;
  }
}

my ($sig, $words);
%words = ();
while (($sig,$words) = each %sig2words) {
  for my $word (@$words) {
    $words{$word} ||= [];
    push @{$words{$word}}, grep($_ ne $word, @$words);
  }
}

# printf STDERR "Loaded Dictionary, \%f seconds\n", time() - $start;

%maxPossible = ();

my $longestpath='unknown';
my $longestlen=-1;

for my $startword (sort keys %words) {
  next if ($maxPossible{$startword} and $longestlen > $maxPossible{$startword});
  my @q = ($startword);
  my %seen = ($startword => 0);
  my $step = 0;
  my @longest;
  while (@q) {
    $step++;
    my @qnext = ();
    for my $w (@q) {
      for my $nw (@{$words{$w}}) {
        next if defined($seen{$nw});
        $seen{$nw} = $step;
        push @qnext, $nw;
      }
    }
    @longest = @q if (!@qnext);
    @q = @qnext;
  }
  $step--;
  if ($step > $longestlen) {
    $longestlen = $step;
    $longestpath = join(", ",
                        map {"$startword -> $_"}
                        grep($_ ge $startword, @longest));
  } elsif ($step == $longestlen) {
    $longestpath = join(", ", $longestpath,
                        map {"$startword -> $_"}
                        grep($_ ge $startword, @longest));
  }
  for my $seen (keys %seen) {
    if (!$maxPossible{$seen} or $maxPossible{$seen} > $step + $seen{$seen}) {
      $maxPossible{$seen} =  $step + $seen{$seen};
    }
  }
}

print "longest is $longestpath at $longestlen steps\n";

# printf STDERR "Total \%f seconds\n", time() - $start;

__END__