Re: [SPOILER] Solution to Perl 'Expert' Quiz-of-the-Week #22

On Sun, Aug 29, 2004 at 12:08:31PM -0400, Daniel Martin wrote:
> Colin Meyer <[email protected]> writes:
> 
> Is there some reason you used this:
> 
> >    sub _rungs {
> >       my $w = shift;
> >       return map { my $c = $w; substr( $c, $_, 1 ) = ''; $c } 0..($SIZE-1);
> >    }
> 
> Instead of this?
> 
> sub _rungs {
>    my $w = shift;
>    return map { my $c = $w; substr( $c, $_, 1 ) = '_'; $c } 0..($SIZE-1);
> }
> 
> Then, you wouldn't have to keep track of what position each rung came
> from, and your %rung2word hash could have a much simpler structure
> (since it could just be $rung2word{$rung} = [$word1, $word2, ...];).
> 
> This also simplifies the code of morph, which is now just a map and a
> grep: [...]

I tried out Daniel's suggestions, and also simplified my searching
data structure some. The speed increase was fairly minimal, about 8%,
which isn't really noticeable when the longest searches are two seconds.

The benefit is that it makes the code a tad easier on the eyes.

-Colin.


#!/usr/local/bin/perl -l
# Colin Meyer [email protected] 2004-08-26
# with Daniel Martin's suggestions

# true for on, false for off
my $CASE_SENSITIVE = 0;
my $DEBUG = 0;

# get stuff from command line
my $start = shift; $start = lc $start unless $CASE_SENSITIVE;
my $end   = shift; $end   = lc $end   unless $CASE_SENSITIVE;
my $DICT = shift;
$DICT ||= '/usr/share/dict/words';

my $size = length( $start );
die "different lengths: $start -> $end.\n" 
   unless $size == length( $end );

build_db( $size );

for ( $start, $end ) {
   die "$_ isn't in the dictionary" unless in_db( $_ ) 
}   

# take $start word. find all words that it morphs to. take $end word,
# do same. Any words in start list equal to end list? if so, we've found
# a solution (check for other solutions at this stage, report shortest).
# Otherwise reiterate, for each word in the lists. track words that have
# been visited, to avoid circles. if ever can't find any more words,
# then give up.

my ( $starts,     # possible paths from the starting word
     $ends,       # possible paths from the ending word
                  # see expand_paths for description of hashref structure
     @solutions,  
     $visited,    # tracks where we've been, so that we don't wander in circles 
     @joins       # track which word joined the start list to the end list
                  # just for curiosity (displayed when $DEBUG is true)
   );

# seed the data search structures
$starts->{ $start }{ list } = [ $start ];
$ends  ->{ $end   }{ list } = [ $end   ];

my $notdone = 1;
while ( $notdone ) {
   my $sc = expand_paths( $starts );
   my $ec = expand_paths( $ends   );

   die "no path!\n" unless ( $sc || $ec );

   # check to see if we've found the solution
   for my $leading_word ( keys %{ $starts } ) {
      if ( exists $ends->{ $leading_word } ) {
         my @list;

         # the half of the solution from $start
         push @list, @{ $starts->{ $leading_word }{ list } };

         # remove the duplicate, matching word
         push @joins, pop @{ $ends->{ $leading_word }{ list } }; 

         # the half from $end
         push @list, reverse @{ $ends->{ $leading_word }{ list } };

         push @solutions, \@list;
         $notdone = 0;
      }
   }
}

my $solution = shift @solutions;
for ( @solutions ) {
   $solution = $_ if @$solution > @$_
} 

print for @$solution;
print scalar( @$solution ), " steps";

END {
  if ( $DEBUG ) {
    require 'YAML.pm'; 
    print "### Joining Words: @joins";
    print YAML::Dump( \@solutions );
    print "### STARTS";
    print YAML::Dump( $starts );
    print "### ENDS";
    print YAML::Dump( $ends );
  }
}


# passed in a hashref, whose keys are the words on the "leading edge" of
# the path, and whose values are hasherefs with these contents:
#   beenseen - a marker so that each list is only expanded once
#   list     - an arrayref of the path that lead up to this word
#
# action is to take each path and create several new paths, by adding all
# of the words that its current leading words can morph to (that haven't
# been used in any of the existing paths). these new paths are added 
# directly back into the hash.
#
# returns a count of how many new paths were created
#
sub expand_paths {
   my $h = shift;
   my $c = 0;
   WORD:
   for my $word ( keys %{ $h } ) {
      next WORD if $h->{ $word }{ beenseen }++;
      for my $nextword ( grep ! $h->{ $_ }, morph( $word ) ) {
         $c++;
         $h->{ $nextword }{ list } = 
               [ @{ $h->{ $word }{ list } }, $nextword ];
      }
   }
   return $c;
}


# database consists of two hashes, %word2rung and %rung2word each word
# has l rungs, where l is its length. a rung is the word with '_'
# substituted for one of its letters.
{
   my ( %word2rung, %rung2word, @words, $SIZE );

   sub build_db {
      $SIZE = shift;

      open DICT, '<', $DICT or die "can't open $DICT: $!";
      @words = grep length( $_ ) == $SIZE, 
               map { chomp; $CASE_SENSITIVE ? $_ : lc $_ } <DICT>;
      close DICT;

      for my $w ( @words ) {
         my @rungs = _rungs( $w );
         $word2rung{ $w } = \@rungs;
         push @{ $rung2word{ $_ } }, $w for @rungs;
      }
   }
   
   sub _rungs {
      my $w = shift;
      return map { my $c = $w; substr( $c, $_, 1 ) = '_'; $c } 0..($SIZE-1);
   }
   
   sub in_db {
      return grep( /$_[0]/, @words );
   }
   
   sub morph {
      my $w = shift;
      my @steps; 
      push @steps, map @$_, @rung2word{ @{ $word2rung{ $w } } };
      return grep $_ ne $w, @steps;
   }
}