Re: Fun with Boggle

[Chris Dolan]

On Dec 6, 2007, at 11:44 AM, Brad Greenlee wrote:

I haven't written any Perl for fun in a while, but I recently  
entertained myself a bit by writing a Boggle puzzle solver in Ruby:

http://blog.footle.org/2007/12/05/cheating-for-fun/

I'm not sure if this particular puzzle has come up before in FWP,  
but I was curious as to how closely this yak could be shaved in  
Perl. I suspect Ton could do it in somewhere around 40 characters.  
Anyone interested?

Brad


Attached is my version coded in Perl which produces identical  
output.  I employed a shortcutting algorithm that resulted in a 77x  
speedup over your Ruby implementation using the same word  
dictionary.  My algorithm stops looking when the current prefix  
matches no known word.  However, my code is 33% longer, counting  
lines.  I think those extra 30 lines are worth saving 7.5 minutes of  
execution time.

% time perl boggler.pl lyltonzigororwho > boggler.pl.out
4.383u 0.275s 0:06.46 71.9%     0+0k 0+0io 0pf+0w
% time ruby boggler.rb lyltonzigororwho > boggler.rb.out
340.764u 5.144s 7:45.79 74.2%   0+0k 0+4io 0pf+0w
% diff boggler.pl.out boggler.rb.out

Chris

#!/usr/bin/perl -w

use strict;
use List::MoreUtils qw(uniq);

my $MIN_LETTERS = 3;
my $MAX_LETTERS = 12;
my @POINTS = (0,0,0,1,2,4,6,9,12, (16)x($MAX_LETTERS-8)); # no idea what the scoring should really be

main();
exit 0;

sub main {
   my $board_letters = shift @ARGV or syntax();
   my @board = init_board(lc $board_letters);
   my ($words, $nwords) = load_words();
   print "loaded $nwords words. solving '$board_letters'...\n";
   my @found;
   for my $i (0..$#board) {
      push @found, walk_board([EMAIL PROTECTED], $i, $words);
   }
   @found = uniq @found;
   my $score = 0;
   for my $word (@found) {
      print "found word: $word\n";
      $score += $POINTS[length $word];
   }
   print 'found ', scalar @found, " words\n";
   print "total score: $score\n";
}

sub syntax {
   die <<"SYNTAX";
Usage: boggler.pl <board string>
  where the board string is all the letters on the board, from left to right
  and top to bottom.
  Example: given the board:
   LYLT
   ONZI
   GORO
   RWHO
  the board string would be: lyltonzigororwho (case is ignored)
  the letter 'q' will automatically have a 'u' appended
SYNTAX
}

sub load_words {
   my $words = {};
   open my $fh, '<', 'words' or die 'Failed to read file "words"';
   my $nwords = 0;
   my $nlines = 0;
   while (my $line = <$fh>) {
      ++$nlines;
      # Remember that line length includes \n
      my $wordlength = -1 + length $line;
      next if $line =~ m/q[^u]/xms; # reject impossible Boggle word
      $line =~ s/qu/q/gxms;
      next if $MIN_LETTERS > $wordlength;
      next if $MAX_LETTERS < $wordlength;
      my $hash = $words;
      for my $letter ($line =~ m/(.)/gxms) {
         $hash = $hash->{$letter} ||= {};
      }
      ++$nwords;
   }
   close $fh;
   #print "Loaded $nwords words, rejected @{[$nlines-$nwords]} words\n";
   return ($words, $nlines);
}

sub init_board {
   my ($board_letters) = @_;

   my $board_size = int(0.5 + sqrt length $board_letters);
   if ($board_size * $board_size != length $board_letters) {
      die "Board is not square! ($board_size x $board_size != @{[length $board_letters]})\n";
   }

   my @board = map { { letter => $_, moves => [], seen => undef } } $board_letters =~ m/(.)/gxms;
   for my $i (0 .. $board_size - 1) {
      for my $j (0 .. $board_size - 1) {
         my $pos = $i + $j * $board_size;
         # Are we at any edges/corners?
         my $i0 = $i > 0;
         my $in = $i < $board_size -1;
         my $j0 = $j > 0;
         my $jn = $j < $board_size -1;
         push @{$board[$pos]->{moves}}, $pos + 1               if $in;
         push @{$board[$pos]->{moves}}, $pos + $board_size + 1 if $jn && $in;
         push @{$board[$pos]->{moves}}, $pos + $board_size     if $jn;
         push @{$board[$pos]->{moves}}, $pos + $board_size - 1 if $jn && $i0;
         push @{$board[$pos]->{moves}}, $pos - 1               if $i0;
         push @{$board[$pos]->{moves}}, $pos - $board_size - 1 if $j0 && $i0;
         push @{$board[$pos]->{moves}}, $pos - $board_size     if $j0;
         push @{$board[$pos]->{moves}}, $pos - $board_size + 1 if $j0 && $in;
      }
   }
   return @board;
}

sub walk_board {
   my ($board, $pos, $words, @letters) = @_;
   my $here = $board->[$pos];
   return if $here->{seen};
   my @found;
   my $nextword = $words->{$here->{letter}};
   if ($nextword) {
      if ($nextword->{"\n"}) {
         push @found, join q{}, @letters, $here->{letter};
      }
      if (@letters < $MAX_LETTERS) {
         $here->{seen} = 1;
         for my $nextpos (@{$here->{moves}}) {
            push @found, walk_board($board, $nextpos, $nextword, @letters, $here->{letter}); 
         }
         $here->{seen} = undef;
      }
   }
   return @found;
}