• For each available vertex:
  • Select it ($seen{$vertex} = 1)
  • Push the vertex to the current path (push @path, $vertex)
  • If the number of vertices in the path equals the desired length (@path == $len)
    • Store the path in the master list (push @all_paths, [@path])
  • Else:
    • Set "available vertices" to all unseen adjacent vertices (grep { !$seen{$_} } @{ $adjacent{$vertex} })
    • Repeat from top
  • Remove the latest vertex added to the path (pop @path)
  • Un-select the vertex ($seen{$vertex} = 0)

my $paths_ref = get_paths(\%adjaceny_matrix, $length);


sub get_paths {
  my ($adj, $len) = @_;
  my @paths;
  _get_paths_helper(\@paths, $adj, $len, [], {}, [keys %$adj]);
  return \@paths;
}


sub _get_paths_helper {
  my ($p, $am, $len, $curr, $seen, $avail) = @_;

  for my $v (@$avail) {
    push @$curr, $v;
    local $seen->{$v} = 1;
    if (@$curr == $len) { push @$p, [@$curr] }
    else {
      _get_paths_helper($p, $am, $len, $curr, $seen, [grep { !$seen->{
+$_} } @{ $am->{$v} }]);
    }
    pop @$curr;
  }
}
[download]

Algorithm::Loops' NestedLoops allows a non-recursive implementation:

use Algorithm::Loops 'NestedLoops';

sub find_path {
  my ($adj_list, $length) = @_;
  my %been_there;
  NestedLoops([
     [sort {$a <=> $b} keys %$adj_list],
     (sub {
        # The last value on @_ has just changed, so remove it from %be
+en_there
        # and set the new one
        my ($last_position, $last_value) = ($#_, $_[-1]);
        delete $been_there{$_} for grep $been_there{$_} >= $last_posit
+ion, keys %been_there;
        $been_there{$last_value} = $last_position;
        # Here I grep out the already-visited nodes, but you could als
+o exclude
        # any letters that don't result in prefixes of real words.
        [ grep !defined($been_there{$_}), @{$adj_list->{$last_value}} 
+]
      }) x ($length-1)]
  );
}

my $i = find_path(\%adjacency_list, 3);
my @path;
print "@path\n" while @path = $i->();
[download]

---

Caution: Contents may have been coded under pressure.

The idea is that if you have the 0/1 adjacency matrix of a graph, and you take that matrix to the Nth power, then the (i,j) entry of the result tells how many paths of length N there are from vertex i to vertex j (here the length is measured in number of edges traversed) .

The only trick is instead of just counting the paths, to keep track of all the actual paths themselves. For this you have to slightly modify the matrix multiplication algorithm...

We modify the adjacency matrix so instead of being 0/1, the (i,j) entry of the matrix is a list of paths from i to j. Then in the matrix multiplication algorithm, instead of multiplying and adding entries, we instead concatenate pairs of paths together and union all of them (respectively). Here's what the code looks like:

use strict;

## just any old directed graph...

my $adj = [ [0,1,1,0,1],
            [1,0,0,0,1],
            [0,1,0,0,0],
            [1,1,1,0,0],
            [0,0,1,1,0] ];
my $dim = 4; ## size of the graph
my $N = 3;   ## length of paths (# of edges, not # of vertices).

## convert each entry in the adjacency matrix into a list of paths
    
for my $i (0 .. $dim) {
  for my $j (0 .. $dim) {
    $adj->[$i][$j] = $adj->[$i][$j] ? [$j] : [];
  }   
}

## compute the $N-th power of the adjacency matrix with our modified
## multiplication

my $result = $adj;
for (2 .. $N) {
   print_paths($result);
   print "========\n";
   $result = matrix_mult($result, $adj);
}

print_paths($result);

## the i,j entry of the matrix is a list of all the paths from i to j,
+ but
## without "i," at the beginning, so we must add it

sub print_paths {
    my $M = shift;
    my @paths;
    for my $i (0 .. $dim) {
      for my $j (0 .. $dim) {
        push @paths, map { "$i,$_" } @{ $M->[$i][$j] };
      }
    }
    print map "$_\n", sort @paths;
}

## modified matrix multiplication. instead of multiplication, we
## combine paths from i->k and k->j to get paths from i->j (this is wh
+y
## we include the endpoint in the path, but not the starting point).
## then instead of addition, we union all these paths from i->j

sub matrix_mult {
    my ($A, $B) = @_;
    my $result;
    for my $i (0 .. $dim) {
      for my $j (0 .. $dim) {
        my @result;
        for my $k (0 .. $dim) {
          push @result, combine_paths( $A->[$i][$k], $B->[$k][$j] );
        }
        $result->[$i][$j] = \@result;
      }
    }
    $result;
}

## the sub to combine i->k paths and k->j paths into i->j paths --
## we simply concatenate with a comma in between.

sub combine_paths {
    my ($x, $y) = @_;
    my @result; 
    
    for my $i (@$x) {
      for my $j (@$y) {
        push @result, "$i,$j";
      } 
    }   
    @result;
}
[download]

0,1
0,2
...
========
0,1,0
0,1,4
0,2,1
0,4,2
...
========
...
0,4,2,1
0,4,3,0
0,4,3,1
0,4,3,2
1,0,1,0
1,0,1,4
1,0,2,1
...
[download]

Sorry for restarting a closed thread. Can this be updated to find acyclic paths. i.e. I don't get these :- 1,0,1,0 1,0,1,4 1,0,2,1 Yes I can eliminate them after I've found them but that would mean a lot of work. Thank You, Himanshu

Depending on what you mean by acyclic paths, you might be able to. I would assume that if you can reach a point with a path of length 2, you don't want to count it again if you can reach it with a path of length 4. This situation might occur if these two points were a part of a path, and they could connect the short way--via two edges, or the long way--using 4 edges. In this case, just define an element wise subtraction operation and subtract all the shorter paths. Aka, calculate A^4 - A^3 - A^2 - A. You might be able to make this faster by leaving markers in your matrix. For example, if two points have been connected using a shorter path, place a -1 into the matrix and force your multiplication algorithm to copy it when the matrix is multiplied. I.e., -1 always maps to -1.

my %adjacency_list = (
                       1 => [2,5,6],
                       2 => [1,3,5,6,7],
                       3 => [2,4,6,7,8],
                       4 => [3,7,8],
                       5 => [1,2,6,9,10],
                       6 => [1,2,3,5,7,9,10,11],
                       7 => [2,3,4,6,8,10,11,12],
                       8 => [3,4,7,11,12],
                       9 => [5,6,10,13,14],
                      10 => [5,6,7,9,11,13,14,15],
                      11 => [6,7,8,10,12,14,15,16],
                      12 => [7,8,11,15,16],
                      13 => [9,10,14],
                      14 => [9,10,11,13,15],
                      15 => [10,11,12,14,16],
                      16 => [11,12,15]
                     );


sub find_path {
  my ($start_at, $length, $been_there) = (@_, {});
  if ($length <= 1) {
    return [$start_at];
  }
  else {
    my @try_these = grep { ! $been_there->{$_} } @{$adjacency_list{$st
+art_at}};
    return map {
      my @cdr_list = find_path($_, $length-1, {%$been_there, $start_at
+ => 1});
      map [$start_at, @$_], @cdr_list;
    } @try_these;
  }
}

# Example usage:
print "@$_\n" for (find_path(3, 3));
[download]

What if we need to find all paths from a node to another specific node? How would we modify the above recursive script?

You'd pass in your destination node instead of desired length, and your first test would be whether you're starting at your destination. So:

sub find_path {
  my ($start_at, $end_at, $been_there) = (@_, {});
  if ($start_at == $end_at) {
    return [$start_at];
  }
  else {
    my @try_these = grep { ! $been_there->{$_} } @{$adjacency_list{$st
+art_at}};
    return map {
      my @cdr_list = find_path($_, $end_at, {%$been_there, $start_at =
+> 1});
      map [$start_at, @$_], @cdr_list;
    } @try_these;
  }
}
[download]

Homework?

---

Caution: Contents may have been coded under pressure.

I like that sort of problems. If only to construct recursive algorithms for them.

Here is a recursive procedure to construct and print out all paths of given length from a last visited node, provided a head path is already given and we know what nodes are left for a potential visit:

use strict;
use warnings;

my %adj = (
    1 => [2,5,6],
    2 => [1,3,5,6,7],
    3 => [2,4,6,7,8],
    4 => [3,7,8],
    5 => [1,2,6,9,10],
    6 => [1,2,3,5,7,9,10,11],
    7 => [2,3,4,6,8,10,11,12],
    8 => [3,4,7,11,12],
    9 => [5,6,10,13,14],
    10 => [5,6,7,9,11,13,14,15],
    11 => [6,7,8,10,12,14,15,16],
    12 => [7,8,11,15,16],
    13 => [9,10,14],
    14 => [9,10,11,13,15],
    15 => [10,11,12,14,16],
    16 => [11,12,15]
);

sub boggle {
    my ($sofar, $last, $remains, $lentogo) = @_;
    return print "@$sofar\n" unless $lentogo;
    return () unless @$remains;
    my (@right, @left) = @$remains;
    while (my $next = shift @right) {
        boggle([@$sofar, $next], $next, [@left, @right], $lentogo-1) i
+f grep {$next==$_} @{$adj{$last}};
        push(@left, $next);
    }
}

for my $len (3 .. 6) {    # len 3 .. 6
    for my $start (1 .. 16) {    # all starting points
        boggle([$start],$start,[1..$start-1,$start+1..16], $len);
    }
};
[download]

the last lines show the application to print out all paths of lengths 3 .. 6 starting anywhere on the 16 grid points.

Edit: fixed a bug in the while loop.

I would think that "all letter arrangements of length N" would not be what you'd want to use for Boggle, because there are a ton of them and if you start with "q" and go to "qz", there is no point in looking up all possible Boggle sequences on the board in your dictionary to see if any of these "qz*" things are words.

Spelling dictionaries are often stored in a trie which is like a big nested hash (but more efficient) where you feed in the letters of your potential word one at a time and can see when you've reached the point where no word starts with those letters.

So I'd recurse over the board and over the trie in parallel, having the trie tell me when to move on (and when I've found a word).

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.

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

There's a boggle game in the bsd-games package which is pre-installed on many linux systems or can be installed with the packaging system. You may want to look at or even use its C source.

Update: boggle even has a batch mode when you don't play the game, only get the words in a table you specify.

boggle -b 'atrieynnilsoelxw' </usr/share/games/bsd-games/boggle/dictio
+nary
[download]

1) There is no limit on word length. Well, okay, there is; they can only be up to sixteen characters because you can't re-use a letter.
2) Using a LOL (list of lists), 4x4, is probably a better way to go. That eliminates the need to carry around %adjacency_list, for one thing.
Hope this helps.

Not to take away your fun on what looks like an interesting programming problem, you might also look at Bookworm by PopCap software. I've enjoyed it immensely -- good value for $20.

Update: And of course, there is always Big Boggle, which uses a 5 x 5 grid -- makes the problem a little more interesting.

Big Boggle? I thought it was called Boggle Master.

Update: wow, so there's even a Boggle Deluxe too.

Btw, I have a Boggle Master but we don't play it much as it doesn't work very well in Hungarian.

Hmmm. Maybe I show my age. :) That's what it was called back when I was a kid ... Big Boggle

  for (my $y = 1; $y <= $q; $y++) {
    for (my $x = 1; $x <= $p; $x++) {
      for (my $ny=$y-1; $ny<=$y+1; $ny++) {
        next if ($ny < 1 || $ny > $q);
        for (my $nx=$x-1; $nx<=$x+1; $nx++) {
          next if ($nx < 1 || $nx > $p || ($nx == $x && $ny == $y));
          push @{$adjlist{"$x,$y"}}, [$nx,$ny];
        }
      }
    }
  }
[download]