Re: find all paths of length n in a graph (Boggle solver)

And here is my solution that walks a trie and the boggle board in parallel. You need to have a dictionary file which is a just list of words, one per line. Then you run the code like:

# To get a random 4x4 board and solve it:
boggle < dictionary
# To get a random board of a different size:
boggle 5 < dictionary
# To use a specific board:
boggle gaut prmr dola esic < dictionary
[download]

An example run on the above sample board finds 229 words plus 20 repeats using the 172823 words in my copy of the enable1 word list.

#!/usr/bin/perl -w
use strict;

$|= 1;

my $width= 4;
my @board;
if(  1 == @ARGV  ) {
    $width= shift @ARGV;
}
if(  @ARGV  ) {
    $width= @ARGV;
    die "Invalid board (@ARGV).\n"
        if  @ARGV != grep /^[a-z]{$width}$/, @ARGV;
    @board= (
        '!', ('!') x $width,
        map( {; '!', /./g } @ARGV ),
        '!', ('!') x $width, '!',
    );
}

my %trie;
my %freq;
my $nWords= 0;
my $nLets= 0;
while( <STDIN> ) {
    chomp;
    $nWords++;
    my $pos= \%trie;
    for my $let ( /./g ) {
        $freq{$let}++;
        $nLets++;
        $pos= $pos->{$let} ||= {};
    }
    undef $pos->{'.'};
}
print "$nWords words added to %trie.\n";

if(  ! @board  ) {
    @board= (
        '!', ('!') x $width,
        map( {; '!', map( randLet(), 1..$width ) } 1..$width ),
        '!', ('!') x $width, '!',
    );
}
my @dir= (  -$width-2, -$width-1, -$width, -1,
            +1, +$width, +$width+1, +$width+2 );
for( 1..$width ) {
    print join ' ', '', @board[ $_*($width+1)+1 .. ($_+1)*($width+1)-1
+ ], $/;
}

my %found;
my $repeats= 0;
for my $start (  grep '!' ne $board[$_], 0..$#board  ) {
    my @used;
    my @pos= $start;
    my @idx;
    my $word= '';
    my @tree= \%trie;
    while( @pos ) {
        my $let= $board[$pos[-1]];
        my $tree= $tree[-1]{$let};
        if(  ! $tree  ) {
            pop @pos;
        } else {
            $used[$pos[-1]]= 1;
            push @tree, $tree;
            push @idx, 0+@dir;
            $word .= $let;
            if(  exists $tree[-1]{'.'}  ) {
                if(  ! $found{$word}++  ) {
                    print 0+keys(%found), " $word\n";
                } else {
                    $repeats++;
                }
            }
        }
        while(  @pos  ) {
            if(  ! $idx[-1]  ) {
                chop $word;
                $used[$pos[-1]]= 0;
                pop @pos;
                pop @idx;
                pop @tree;
            } else {
                my $pos= $pos[-1] + $dir[--$idx[-1]];
                if(  ! $used[$pos]  ) {
                    push @pos, $pos;
                    last;
                }
            }
        }
    }
}
print "plus $repeats repeats\n";

sub randLet
{
    my $cnt= int rand $nLets;
    for( keys %freq ) {
        $cnt -= $freq{$_};
        return $_   if  $cnt < 0;
    }
    die "Impossible";
}
[download]

Update: Removed off-by-one error in counts displayed for found words.

- tye

Comment on Re: find all paths of length n in a graph (Boggle solver) Select or Download Code

Replies are listed 'Best First'.

Re^2: find all paths of length n in a graph (trie -- boggle solver)
by demerphq (Chancellor) on Jan 10, 2006 at 22:56 UTC

Here is an implementation of the description you gave in the CB of how you would do it. Actually, youd probably do it neater than this somehow or another, but whatever. :-)

Update: Made it start at N and go clockwise instead of at NW. Also, made it run from command line line args. Example usage (and defaults) are below. (added later) cleanup and additional documentation. (and even later) Heh, "Perl-Monk-sHac-kers" can be used to spell "acne", and "sane". :-)

boggle.pl GAUT-PRMR-DOLA-ESIC D:/dict/enable1.txt
[download]

# boggle.pl
use strict;
use warnings;

use Storable;
use Text::Wrap qw(wrap);

# Boggle board board is representated as a flat array 
# with guard squares surrounding the valid squares on 
# all sides. Thus the virtual board size is +2 over the 
# "real" board size.

my $RealSize= 4;
my $BoardSize= $RealSize + 2;
my @board= (" ") x ( $BoardSize ** 2 ); 

# what do we add to "move" from one square to the next.
my @delta= ( -6, -5, 1, 7, 6, 5, -1, -7  ); # N, NE, E, ..., W, NW
my %loc_mask; # map valid locations on the board to specifc bits
              # we use this to prevent visiting a location twice.
my @inorder;  # valid locations on the board in order of 1,1 to 4,4
my $trie= {}; # trie of words in dictionary
              # Digit => HoH of possible successor words.
              # '' => 1 indicates path to this node is a valid word
              # $trie->{words} holds the count.

sub setup {
    my $file= shift;
    # first set up the information about the board
    my $bit= 0;
    for my $y ( 1 .. $RealSize ) {
        for my $x ( 1 .. $RealSize ) {
            my $loc= $x + ( $y * $BoardSize );
            $loc_mask{$loc}= 2 ** ($bit++);
            push @inorder, $loc;
        }
    }

    # Now read the dictionary. If we have already built a trie
    # of the dictionary it might be available as a Storable image
    if ( -e "$file.stor" && -M "$file.stor" < -M $file ) {
        print "Reading stored dictionary... ";
        $trie = retrieve("$file.stor");
        print "$trie->{words} words read\n";
    } else {
        # No up to date storable of the dictionary available.
        print "Reading dictionary... ";
        open my $in,"<",$file
            or die "Can't read '$file':$!";
        while (<$in>) {
            chomp;
            next if length $_ > 16;
            my $n=$trie;
            # add the word to the trie...
            $n= ( $n->{$_} ||= {} )
                for split //, uc $_;
            # mark the last node visited as an accepting state
            $n->{''}=!!1;
        }
        $trie->{words}= $.;
        print "$trie->{words} words read\n";
        print "Storing...";
        store $trie, "$file.stor";
        print "Done\n";
    }
}

# recurse through the possible paths on the board
# using the trie to determine which paths are legal.
sub recurse_find {
    my ( $loc, $words, $node, $bits, $word )= @_;
    if ( $node->{''} ) {
        push @$words,$word;
    }
    foreach my $d (@delta) {
        my $new= $loc+$d;
        my $char= $board[$new];
        if ( $node->{$char} and !($bits & $loc_mask{$new}) ) {
            recurse_find( $new,
                          $words,
                          $node->{$char},
                          $bits + $loc_mask{$new},
                          $word . $char );
        }
    }
}

sub printboard {
    local $_= join "",@board;
    s/^\s+/ /;
    s/\s+$/ /;
    s/  /\n /g;
    print $_,"\n------\n";

}

# loop through all the possible starting positions
# to see what words we find
sub find_words_in_board {
    @board[@inorder]= split //,uc(shift @_);
    my @words;
    printboard();
    foreach my $loc ( @inorder ) {
        my $c=$board[$loc];
        next if ! $trie->{$c};
        recurse_find( $loc,
                      \@words,
                      $trie->{$c},
                      $loc_mask{$loc},
                      $c );
    }
    my %unique;
    $unique{$_}++ for @words;
    print "Got ",0+@words," possible words (",
                 0+keys(%unique)," unique)\n";
    print wrap("","",join ", ",
               map { $unique{$_}>1 ? "$_($unique{$_})" : $_ }
               sort keys %unique),"\n";
}

$|++;

my $board= uc(shift @ARGV) || 'GAUTPRMRDOLAESIC';
my $file= shift(@ARGV) || "D:/dict/enable1.txt";

$board=~s/[^A-Z]//g;

die "Bad board! '$board'" if length($board)!=16;
die "Dictionary '$file' doesn't exist!"
  unless -e $file;

setup($file);
find_words_in_board($board);

__END__
Reading stored dictionary... 172823 words read
 GAUT
 PRMR
 DOLA
 ESIC
------
Got 249 possible words (229 unique)
AG, AI, AIL, AILS, AIS, AL, ALMA, ALOE, ALOES, ALS, ALSO, AM(2), AMA(2
+),
AMTRAC, AMU(2), APOD, APODS, AR(2), ARM(2), ARMOR, AROMA, AROSE, ART,
ARUM(2), AURA, AURAL, CALM, CALO, CAM, CAR, CARL, CARLS, CART, CIS, CL
+AM,
CLAMOR, CLOD, CLODS, CLOP, CLOSE, CLOSED, DE, DO, DOE, DOES, DOL, DOLC
+I,
DOLMA(2), DOLS, DOM, DOMAL, DOPA, DOR, DORM, DORP, DOS, DOSE, DRAG, DR
+AM,
DRAMA, DROP, DRUM, ED, ES, GAM, GAMA, GAMUT, GAP, GAR, GARLIC, GAUM,
GAUR(2), GRAM, GRAMA, GRUM, GRUMOSE, IS, LA, LAC, LAIC, LAM, LAMA, LAR
+,
LARUM, LI, LIAR, LIS, LO, LODE, LODES, LOP, LORD, LORDS, LOSE, MA(2), 
+MAC,
MAG, MAIL, MAILS, MALIC, MAP, MAR(2), MARL(2), MARLS(2), MART, MAUT, M
+O,
MOD, MODE, MODES, MODS, MOIL, MOILS, MOL, MOLA, MOLAR, MOLS, MOP, MOR,
MORA, MOS, MU, MURA(2), MURAL, MURALS, MUT, OD, ODE, ODES, ODS, OE, OE
+S,
OIL, OILS, OM, OP, OR, ORA, OS, OSE, PA, PAM, PAR, PARD, PARDS, PAROL,
PAROLS, PARURA, POD, PODS, POI, POIS, POISE, POISED, POL, POLAR, POLIS
+,
POLS, POM, POSE, POSED, PRAM, PRAU, PRO, PROD, PRODS, PROM, PROS, PROS
+E,
PROSED, RAG, RAIL, RAILS, RAISE, RAISED, RAM(2), RAMOSE(2), RAMROD,
RAMRODS, RAP, ROD, RODE, RODS, ROE, ROES, ROIL, ROILS, ROM, ROSE, ROSE
+D,
RUM(2), RUMOR, RURAL, RURALISE, RURALISED, RUT(2), SI, SIAL, SIC, SILO
+,
SILOED, SLAM, SLOE, SLOP, SO, SOD, SOIL, SOL, SOLA, SOLAR, SOLI, SOMA(
+2),
SOP, SORA, SORD, TRAIL, TRAILS, TRAM, TUMOR, TURD, TURDS, TURMOIL(2),
TURMOILS(2), UM, URACIL, URACILS, URD, URDS, UT
[download]

---
$world=~s/war/peace/g

[reply]
[d/l]
[select]


Perl Monk, Perl Meditation
	PerlMonks