How can I use Mathematica's graph functions to cheat at Boggle?

Boggle is a word game played with 16 dice and a 4x4 tray. This question is inspired by a Stack Overflow question about Boggle that I decided to solve using Mathematica. In addition to Mathematica, I thought I'd use some of the new version's graph-related functionality, which I've never really explored in the past. It seemd like a natural fit, but the further I got into my program, the more awkward everything seemed. First, the board from the orginal question:

F X I E
A M L O
E W B X
A S T U

I use a mix of features to turn this into a Graph; with ImportString I was able to copy and past from my browser directly into a string literal in my notebook.

makeBoggleBoard[s_String] :=
makeBoggleBoard@ImportString[s]

makeBoggleBoard[mat : {{__String} ..}] /; MatrixQ[mat] :=
With[{dims = Dimensions@mat,
cPatt = {_Integer, _Integer},
dPatt = Alternatives[{1, 0}, {0, 1}, {1, -1}, {1, 1}]
},
With[{coords = Tuples[Range /@ dims]},
With[{
vertexRules =
edgePattern = {c1 : cPatt, c2 : cPatt} /; MatchQ[c1 - c2, dPatt]
},
Graph@Cases[Tuples[coords, 2],
c : edgePattern :> ((UndirectedEdge @@ c) /. vertexRules)]]]]

This already seems a little bit clunky. Most of the difficulty comes about from trying to associate a letter with each vertex in my graph while keeping all the vertices distinct. However, this mostly seems to work well.

Also, it will help to winnow the dictionary so it only contains valid words (they must have more than three letters and only use letters on the board). This part, at least, is pretty easy and quick:

makeBoggleDictionary[board_Graph] :=
With[{chars =
ToLowerCase@DeleteDuplicates@(VertexList@board)[[All, -1]]},
DictionaryLookup[chars ~~ chars ~~ chars ~~ (chars ...)]];

Now it's time to traverse the graph, finding all the words along the way. We need to traverse each possible path from each vertex, check to see if the path so far spells a word, and if it does, collect it. In order to keep performance reasonably in hand, we want to cull paths that can't possible spell a word as quickly as possible. Here's the function I came up with:

findWordsInBoggleBoard[graph_Graph, dict : {__String}] :=
With[{
makeWord = ToLowerCase@StringJoin[#[[All, 2]]] &,
lookup =
Function[pattern,
Flatten[StringCases[dict,
StartOfString ~~ pattern ~~ EndOfString]]]
},
Module[{extendPaths},
extendPaths[v_, {}] :=
DeleteCases[VertexList@NeighborhoodGraph[graph, v], v]},
Join @@ (extendPaths[#, {{v}}] & /@ adj)];
extendPaths[v_, paths_] :=
Module[{
extended = Append[#, v] & /@ paths,
nexts,
strings,
feasible,
strings = makeWord /@ extended;
Scan[
Sow,
lookup[Alternatives @@ strings]
];

feasible =
Pick[
extended,
Function[string,
MatchQ[
Select[lookup[string ~~ __],
StringLength@# >= 3 &], {__String}]] /@ strings];

nexts =
DeleteCases[
{#, Select[feasible, Function[path, FreeQ[path, #]]]} & /@ adj,
{{_, _}, {}}];

extendPaths @@@ nexts
];

Reap[Scan[extendPaths[#, {}] &, VertexList@graph]] /.
{{Null, {}} -> {}, {Null, {words : {__String}}} :> Union@words}]]

The performance is sort of acceptable (it takes about 3 seconds to find all the words in the sample board), but the entire approach I'm taking here seems very ugly. In particular, the repeated use of NeighborhoodGraph to find adjacent vertices in the recursion for extendPaths seems faintly ridiculous, and the whole approach feels quite low-level compared to some of the other graph functions.

Can anyone suggest some possible ways to speed this up?

EDIT: Part of what I'm interested in seeing is whether Mathematica's graph functions are a good fit for this problem, though of course I'm happy to see the good, fast implementations that people have posted.

• I expressed my general opinion on the applicability of Mathematica Graph - related functionality to this prolem at the bottom of my post - please see the edit. May 10 '12 at 11:02
• I fully agree with leonid's assessment of using built-in graph functions for this problem. In fact, those were very much the same reasons for which I chose the method I did — you need a custom graph traversing function which doesn't fit exactly into breadth/depth first traversing logic or the shortest path/tour.
– rm -rf
May 10 '12 at 17:32
• Of course, once you have this, you can run interesting experiments like generating a few thousand random boggle boards and figuring out the probability of various word lengths, or what the most productive starting letter is. Jun 1 '12 at 14:33

Preview and comparative results

The implementation below may be not the most "minimal" one, because I don't use any of the built-in functionality (DictionaryLookup with patterns, Graph-related functions, etc), except the core language functions. However, it uses efficient data structures, such as Trie, linked lists, and hash tables, and arguably maximally avoids the overheads typical in Mathematica programming. The combined use of Trie, linked lists, and recursion allows the main function to copy very little. The use of trie data structure allows me to be completely independent of the system DictionaryLookup function.

Why is this critical here? Because the nature of the problem makes only a single last letter important for the next traversal step, and constructing the whole word (containing all previous letters) just to check that it exists is a waste, and this is arguably the reason why other solutions are both much slower and do not scale so well. Also, the preprocessing step, while rather costly (takes about 6 seconds on my machine), has to be done only once, to initialize the "boggle engine" (moreover, the resulting trie can be stored in e.g. .mx file for later reuse, avoiding this overhead for subsequent uses), while in other posted solutions some preprocessing has to be done for every particular board.

The main message I want to deliver is that, for the top-level Mathematica code, the choice of efficient data structures is crucial. Our Mathematica programming instincts demand that we reuse as much of the built-in functionality as possible, but one always has to question how well the existing functionality matches the problem. In this particular case, my opinion is that neither the built-in Graph - related functions nor the DictionaryLookup with patterns bring much to the table. To the opposite, these functions force us to use unnatural for this problem data representations and/or algorithms, and this is what leads to the slowdowns. I may be over-emphasizing this point, but this was exactly the essence of the question.

Now, some timing comparisons (note that for the solution of @R.M., I had to include the pieces defining adjnodes, letters and dict variables, into the timing measurements):

• Board 4x4 (the original one):

• Pillsy 3.3 sec
• R.M. 1.4 sec
• L.S. 0.04 sec
• Board 5x5:

"E I S H R
B D O I O
T R O E X
Z U Y Q S
I A S U M"

• Pillsy 18.8 sec
• R.M. 7.6 sec
• L.S. 0.05 sec
• Board 7x7

"E I E G E O T
A O B A U R A
N E I P L A Y
O O I I C A T
I I F U N L A
S T I N G E W
U H L E O X S"

• Pillsy 373.8 sec
• R.M. 191.5 sec
• L.S. 0.18 sec

So, you can see that for larger boards, the difference between the running times is even more dramatic, hinting that the solutions have different computational complexities.

I took the trouble to perform and present all these timings because I think that this problem is an important counterexample to the "conventional wisdom" to favor shorter implementations utilizing built-ins over the hand-written top-level mma code. While I agree that in general this is a good strategy, one has to always examine the case at hand. To my mind, this problem presents one notable exception to this rule.

Implementation

The following solution will not use Mathematica graphs, but will be about 100 times faster (than the timings you cite), and will rely on this post. I will borrow a function which builds the word tree from there:

ClearAll[makeTree];
makeTree[wrds : {__String}] := makeTree[Characters[wrds]];
makeTree[wrds_ /; MemberQ[wrds, {}]] :=
Prepend[makeTree[DeleteCases[wrds, {}]], {} -> {}];
makeTree[wrds_] :=
Reap[If[# =!= {}, Sow[Rest[#], First@#]] & /@
wrds, _, #1 -> makeTree[#2] &][]

Its use is detailed in the mentioned post. Now, here is a helper function which will produce rules for vertex number to letter conversion, and adjacency rules:

lrules = Thread[Range[Length[#]] -> #] &@Flatten[letterMatrix];
p =
Partition[Array[a, Length[lrules]], Last@Dimensions@letterMatrix],
1
];
Flatten[
ListConvolve[{{1, 1, 1}, {1, 2, 1}, {1, 1, 1}}, p] /. Plus -> List /.
{left___, 2*v_, right___} :> {v -> {left, right}} /. a[x_] :> x];
];

It is pretty ugly but it does the job. Next comes the main function, which will find all vertex sequences which result in valid dictionary words:

EDIT

Apparently, there is a problem with Module-generated inner functions. I used Module in getVertexSequences initially, but, because in my benchmarks I happened to use a previous incarnation of it with a different name (where I did not yet modularize the inner functions), I did not see the difference. The difference is an order of magnitude slow-down. Therefore, I switched to Block, to get back the performance I claimed (You can replace back the Block with Module to observe the effect). This is likely related to this issue, and is something anyone should be aware of IMO, since this is quite insidious.

END EDIT

Clear[getVertexSequences];
Block[{subF, f, getWordsForStartingVertex},
(* A function to extract a sub-tree *)
subF[v_, tree_] :=
With[{letter = v /. letterRules},
With[{res = letter /. tree},
res /; res =!= letter]];
subF[_, _] := {};
(* Main function to do the recursive traversal *)
f[vvlist_, {{} -> {}, rest___}] := f[Sow[vvlist], {rest}];
f[_, {}] := Null;
f[vvlist : {last_, prev_List}, subTree_] :=
Scan[
f[{#, vvlist}, subF[#, subTree]] &,
];
(* Function to post-process the result *)
getWordsForStartingVertex[v_] :=
If[# === {},
#,
Reverse[Map[Flatten, First@#], 2]
] &@Reap[f[{v, {}}, subF[v, allTree]]][];
(* Call the function on every vertex *)
Flatten[Map[getWordsForStartingVertex, Range[n]], 1]
]

At the heart of it, there is a recursive function f, which acts very simply. The vvlist variable is a linked list of already visited vertices. The second argument is a sub-tree of the main word tree, which corresponds to the sequence of already visited vertices (converted to letters. To understand better what the sub-tree is, see the mentioned post). When the sub-tree starts with {} -> {}, this means (by the way word tree is constructed), that the sequence of vertices corresponds to a valid word, so we record it. In any case, if the subtree is not {}, we Scan our function recursively on adjacent vertices, removing from them those we already visited.

The final functions we need are the one to convert vertex sequences to words, and the one to construct the trie data structure. Here they are:

Clear[wordsFromVertexSequences];
wordsFromVertexSequences[vseqs_List, letterRules_] :=
Map[StringJoin, vseqs /. letterRules];

ClearAll[getWordTree];
getWordTree[minLen_Integer: 1, maxLen : (_Integer | Infinity) : Infinity] :=
makeTree[
Select[ToLowerCase@DictionaryLookup["*"],
minLen <= StringLength[#] <= maxLen &]];

The function to bring this all together:

ClearAll[getWords];
getWords[board_String, wordTree_] :=
getWords[ToLowerCase@ImportString@board, wordTree];
getWords[lboard_, wordTree_] :=
wordsFromVertexSequences[
Times @@ Dimensions[lboard]],
lrules
]
];

Illustration

First, construct a full tree of all words in a dictionary. This preprocessing step can take a little while:

largeTree = getWordTree[];

Now, construct the word matrix:

wmat = ToLowerCase@ImportString@
"F X I E
A M L O
E W B X
A S T U"

{{"f", "x", "i", "e"}, {"a", "m", "l", "o"}, {"e", "w", "b","x"}, {"a", "s", "t", "u"}}

Next, construct the rules for vertex-to-letter conversion and adjacency rules:

{Dispatch[{1->f,2->x,3->i,4->e,5->a,6->m,7->l,8->o,9->e,10->w,11->b,
12->x,13->a,14->s,15->t,16->u},-DispatchTables-],
Dispatch[{1->{2,5,6},<<14>>,16->{11,12,15}},<<1>>]}

We are now ready to use our function:

{0.0185547,{{1,5},{1,5,2},{1,5,6,9},{1,6},<<89>>,{15,14},
{15,16,11},{15,16,11,14},{15,16,12}}}

Note that it took very little time to get the result. We can finally convert it to words:

wordsFromVertexSequences[seqs,lrules]//Short

{fa,fax,fame,fm,xi,xml,xl,<<84>>,twas,tb,ts,tub,tubs,tux}

The way to call a final function:

(* Do this only once per session *)
$largeTree = getWordTree; board = ToLowerCase@ImportString@"F X I E A M L O E W B X A S T U" getWords[board,$largeTree]

{fax,fame,xml,imf,eli,elm,elma,<<59>>,stub,twa,twa,twas,tub,tubs,tux}

(note that the result differs from that in illustration section, since I am now using the word tree with words with less than 3 letters excluded - using the $largeTree rather than largeTree now). Discussion Of course, I was a bit cheating in the sense that the preprocessing time takes a while, but this has to be done only once. My main point is that I think, the Trie data structure (my interpretation of it) is the right one here, and coupled with linked lists and hash tables (Dispatch-ed rules), it leads to a rather simple solution. The essence of the solution is expressed in function f, which is just a few lines long and more or less self-documenting. And, also, the solution itself turns out quite fast (especially given that this uses just the top-level mma, no packed arrays, Compile, etc). EDIT 2 To address the question in your edit, and generally the question on applicability of Mathematica's new Graph functionality to this problem: I think, that while you can use new Graphs to solve the problem, it is not a natural choice here. I may be wrong, of course, but these are my reasons: • The graph traversal you need for this problem does not fit directly into either one of DepthFirstScan and BreadthFirstScan built-in graph-traversal functions. Rather, it is a kind of enumeration of all possible depth-first traversals starting at a given vertex. • Those traversals should stop as soon as it becomes clear that no words can be constructed by going to any of the adjacent vertices. This can be also achieved in DepthFirstScan through the use of Catch and Throw, but it is rather inelegant, and will also induce an overhead. • The general ideology of DepthFirstScan and BreadthFirstScan is somewhat similar to a visitor design pattern used for a tree traversal. The idea is that the traversal is done for you, while you have to supply the functions to be called on tree (or graph) nodes. This approach works well when your traversal matches exactly the one implemented by the pattern. For example, most of the time, a tree is traversed depth-first. However, I had many chances to observe (in other languages) that as soon as I have to modify the traversal even slightly, using the tools like that creates more problems than it solves. The main question to ask yourself is this: does you traversal (sequence of visited vertices) depend on the content of the vertices (information you get during the traversal)? If yes, then it is more than likely that custom general traversal functions will not give you a good solution, because you then need more control over the way traversal is performed. The whole idea of visitor pattern (used for tree traversals) and the like is that you can separate the traversal itself from the information-processing during the traversal, and it's just not true for data-dependent traversals, where you can not really decouple traversal from the data-processing of the tree (or graph) nodes. I think that we should separate cases where graphs represent just a useful abstraction to think about the problem, from those where the problem can be solved by means of more or less standard graph-theoretical functionality (in particular that present in Mathematica), once it is reformulated in an appropriate way. The case at hand clearly looks to me like belonging to the first category. • I'm not sure what your definition of a little while is, but on my machine (2.53 GHz Intel Core i5, MacOS 10.6.8) making the large tree runs in a little under 6 seconds. Where is the function getWords defined? May 10 '12 at 1:05 • It's interesting that having a trie on hand is so helpful; I assumed my problem had more to do with controlling the number of possible paths than the data structure for looking up words. May 10 '12 at 2:03 • @rcollyer Thanks for the notice. getWords was a previous incarnation of getVertexSequences. They are exactly the same, I just renamed the former to the latter. Since both were defined in the workspace, I did not notice that in my tests / benchmarks. Will edit now. As for "a little while", yes, 6s. is about right, so for a single run, my solution is not really fast. But, for many runs, this will matter less, and besides, this dictionary tree can be stored in e.g. .mx file, since it may ba also useful for other applications. We only have to build it once. May 10 '12 at 8:36 • @Pillsy Your assumption is probably right in general, but you did not account for the huge overhead of top-level mma. Here, I reduce it to a mimimum, and I think this is a good illustration of what immutable data structures can buy you. Both the list of already visited vertices (vvlist parameter of f), and a given (sub) tree, only contain one or just a few pointers to be copied. So, my recursive function is maximally efficient, because it copies very little. Also, I don't have to build words from letters - it is a waste for this problem, where just a single last letter is always important. May 10 '12 at 8:46 • @rcollyer Please see also the edit - my mistake of using a development version (getWords) had other consequences. I am just happy that I did not use the Module-generated inner functions from the start - in which case, I would beleive that the fastest it can run is in half a second (which is 10-20 times slower than the current version based on Block - localized variables). May 10 '12 at 9:40 My solution is a recursive tree traversal algorithm which seeks and searches neighbouring vertices only if it will lead to a word (e.g., Something starting with ZQ is immediately disqualified), but it's faster than yours because I construct the adjacent vertices list from the adjacency matrix rather than calling NeighborhoodGraph each time. On my machine, yours runs in about 8 s, and mine in under 1 s. Here's the final prettified output that you can use to cheat at boggle :) Implementation 1. Construct the adjacency matrix for a generic boggle grid. Boggle grids are square. The adjacency matrix has a nice structure to it, which allows you to construct it neatly for any$n\times n$grid. Here's the function to create it: boggleAdjMatrix[n_] := Module[{grid, diag, patt, eye}, grid = SparseArray[{Band[{1, 1}] -> patt, Band[{2, 1}] -> eye, Band[{1, 2}] -> eye}, {n, n}] // Normal; diag = SparseArray[{Band[{2, 1}] -> patt, Band[{1, 2}] -> patt}, {n, n}] // Normal; patt = SparseArray[{Band[{2, 1}] -> 1, Band[{1, 2}] -> 1}, {n, n}] // Normal; eye = IdentityMatrix[n]; ArrayFlatten[grid + diag] // Unitize ] Now for the above board of letters, you can create the graph from the adjacency matrix, and simply label the vertices (s is the string in your first code block, just copy-pasted): With[{letters = StringSplit[s]}, AdjacencyGraph[boggleAdjMatrix[Sqrt[Length@letters]], VertexLabels -> Table[i -> letters[[i]], {i, Length@letters}]] ] You can also get the matrix from your approach by calling AdjacencyMatrix[graph], but I find this easier to follow. 2. Create helper functions and neighbourhood list I create some helper functions to create a smaller dictionary of valid words, to check if a word is in that dictionary, to test whether a given path could ever lead to a word, and to sow a word that is legal Clear[dictionary, wordQ, proceedQ, sowWord] dictionary[list_List] := With[{chars = DeleteDuplicates@list}, DictionaryLookup[x : chars ... /; StringLength[x] >= 3, IgnoreCase -> True]]; wordQ[dict_List, word_String] /; StringLength[word] >= 3 := Or @@ StringMatchQ[dict, word] proceedQ[dict_List, word_String] := Or @@ StringMatchQ[dict, word ~~ ___] sowWord[dict_List, s_String] /; StringLength[s] >= 3 := Sow[s] /; wordQ[dict, s] For the adjacent nodes, instead of using NeighborhoodGraph repeatedly, I create a list of adjacent nodes, which you can easily get from the adjacency matrix: adjNodes = With[{list = First /@ ArrayRules[boggleAdjMatrix] // Most}, Map[Last, SplitBy[list, First], {2}]] 3. Traverse the graph and find dictionary words Now you can simply index the$i$th element to get the neighbours. For example, adjNodes[] gives you {5, 6, 7, 9, 11, 13, 14, 15}. With the above, we're all set to find the words. First a couple of initializations: letters = {"F", "X", "I", "E", "A", "M", "L", "O", "E", "W", "B", "X", "A", "S", "T", "U"}; dict = ToUpperCase@dictionary[letters]; currentWord[visited_List] := StringJoin @@ letters[[visited]]; The following is the main function that traverses the graph starting from a given vertex. It moves forward only if the word in the current path could ever lead to a word at a future node. Clear[stepForward] stepForward[current_, visited_: {}] := Module[{$visited, $currentWord}, With[{$possibleNodes = DeleteCases[adjNodes[[current]], Alternatives @@ visited]},
$visited = Append[visited, current];$currentWord = currentWord[$visited]; sowWord[dict,$currentWord];
stepForward[#, $visited] & /@$possibleNodes /; proceedQ[dict, $currentWord] ] ] And finally, run it on the entire graph: wordsFromVertex[v_] := stepForward[v] // Reap // Last wordsFromVertex /@ Range (* {"FAX", "FAME", "XML", "IMF", "ELI", "ELM", "ELMA", "AXLE", "AMIE", "AMBLE", "AWL", "AWE", "AWES", "MIX", "MIL", "MILE", "MILO", "MAX", "MAXI", "MAE", "MAW", "MAWS", "MEW", "MEWL", "MEWS", "MES", "MESA", "LIE", "LIMA", "LIME", "LIMES", "LIMB", "LIMBO", "LIMBS", "LEI", "LEO", "LOB", "LOBS", "LOX", "OIL", "OLE", "EMIL", "EMILE", "EAST", "WAX", "WEST", "WAS", "WAST", "BMW", "BOIL", "BOLE", "BOX", "BUT", "BUTS", "AWL", "AWE", "AWES", "SEA", "SEAM", "SEMI", "SEW", "SEA", "SWAM", "SWAMI", "SAW", "STU", "STUB", "TWA", "TWA", "TWAS", "TUB", "TUBS", "TUX"} *) Presentation and solution viewer This part assembles the bogle board and tiles neatly and provides an interactive viewer with which you can move backward and forward to view the solutions and the path that leads to them. First a couple of slightly modified helper functions: Clear[sowPath, stepForward2] sowPath[dict_List, s_String, visited_] /; StringLength[s] >= 3 := Sow[visited] /; wordQ[dict, s] stepForward2[current_, visited_: {}] := Module[{$visited, $currentWord}, With[{$possibleNodes = DeleteCases[adjNodes[[current]], Alternatives @@ visited]},
$visited = Append[visited, current];$currentWord = currentWord[$visited]; sowPath[dict,$currentWord, $visited]; stepForward2[#,$visited] & /@ $possibleNodes /; proceedQ[dict,$currentWord]
]
]

Here's the main function that pretty-prints the boggle board:

With[{coords = (Table[{j, i}, {i, 4}, {j, 4}]~Flatten~1),
paths = (stepForward2 /@ Range // Reap // Last)~Flatten~1,

Module[{g, vertexFun, edgeFun, list = N@coords[[paths[[#]]]] &},
vertexFun[v_] := If[MemberQ[list[v], #],
{LightGreen, EdgeForm[{Thick, Darker@Green}],
Rectangle[# - 1/2, # + 1/2, RoundingRadius -> .1], Black,
Text[Style[letters[[#2]], FontSize -> 16], #1]},
{LightYellow, EdgeForm[{Thick, Darker@Yellow}],
Rectangle[# - 1/2, # + 1/2, RoundingRadius -> .1], Black,
Text[Style[letters[[#2]], FontSize -> 16], #1]}
] &;

edgeFun[v_] := {Red, Thick, Arrow[#, 1/4] & /@ Partition[list[v], 2, 1]};

VertexShapeFunction -> vertexFun[v], EdgeStyle -> Opacity,
ImageSize -> 300, Epilog -> First@Graphics[edgeFun[v]]];

Panel@DynamicModule[{i = 1},
Column[{
Dynamic@
Row[{Button["Previous", i -= 1, Enabled -> (i > 1)],
Button["Next", i += 1, Enabled -> (i < Length[paths])]}],
Dynamic@Labeled[g@i, Style[Text@currentWord@paths[[i]], FontSize -> 14], Top]
}]
]
]
]
• Of course, you do realize that any +1 I give is dependent on whether or not you beat Leonid's Answer, right? May 10 '12 at 0:58
• At the moment, I can't Leonid's to run, so I guess you can have your +1. May 10 '12 at 1:11
• Nice visualization. I wanted to do something like this, but you did it first. +1. May 11 '12 at 10:37
• @LeonidShifrin It was the last chip I had... You've already won the speed game by a HUGE margin :)
– rm -rf
May 11 '12 at 14:21
• @rm-rf "we were all like piranhas, trying to answer every question" - right, but I think that was necessary. We have created a high density of expert attention to get the site going. I believe that this is a critical component for the site to develop. Actually, I think that the current state where we have many more basic questions is partially due to the decrease of this density of expert attention, not only the other way around. Apr 25 '13 at 15:12