# Solving word search puzzles

I am trying to create a code that can identify the following terms in a grid of letters: MATHEMATICA, STACK, EXCHANGE and USERS.

list1={"M","S","T","A","S","I","S","X","X","T","R","X"};
list2={"A ","T ","H ","X ","R ","X ","G ","R ","S ","H ","X ","A"};
list3={"M","A","T","H","E","M","A","T","I","C","A","I"};
list4={"A","X","S","G","S","X","A","I","R","T","X","T"};
list5={"T","I","T","G","U","C","C","I","R","N","X","A"};
list6={"T","A","S","X","K","G","X","H","X","A","R","C"};
list7={"H","E","R","S","I","S","G","X","A","C","E","C"};
list8={"E","H","T","H","T","I","A","T","X","N","X","X"};
list9={"S","H","H","S","R","S","X","X","S","X","G","X"};
list10={"S","G","A","S","T","A","E","G","A","G","X","E"};
listAll={list1,list2,list3,list4,list5,list6,list7,list8,list9,list10};
Find[listAll,"MATHEMATICA"];
Find[listAll,"STACK"];
Find[listAll,"EXCHANGE"];
Find[listAll,"USERS"];


I am thinking that this command would not be the most appropriate

Animation (Ilustrative):

How can I create more practical way to list "listAll"?

• What exactly do you mean by Find? Find out if the words are there are not? Find the positions in the lists of the letters in the words (if it is there)? ETc. Aug 22, 2016 at 20:13
• First if the words can be formed. If so, where the letters which would be the combination of lists. For example, the second letter of list2 + third letter of list3 + ... Aug 22, 2016 at 20:29
• you might find this useful StringMatchQ[ StringJoin@Diagonal[listAll, 2], ___ ~~ "EXCHANGE" ~~ ___] (Note you have a bunch of stray spaces in your input , by the way) Aug 22, 2016 at 20:30
• Or as an image with the words highlighted. Not necessarily as an animation. Aug 22, 2016 at 20:35
• Related: (5387) Aug 22, 2016 at 22:25

Here we go...

highlightString[board_, str_] := With[{l = Characters[str]},
board // horizontal[l] // vertical[l] // diagonal[l] // diagonalReversed[l]]

horizontal[letters_][board_] := applyStyle[letters] /@ board
vertical[letters_][board_] := Transpose[applyStyle[letters] /@ Transpose[board]]
diagonal[letters_][board_] := diagonalD[applyStyle[letters] /@ diagonalU[board]]
diagonalReversed[letters_][board_] := diagonalU[applyStyle[letters] /@ diagonalD[board]]

diagonalU[board_] := Transpose@MapIndexed[RotateLeft]@Transpose[board]
diagonalD[board_] := Transpose@MapIndexed[RotateRight]@Transpose[board]

style[character_] := Style[character, Bold, Red]
style[character_Style] := character

applyStyle[letters_][row_] := MapAt[style, row, position[row, letters]]
position[row_, letters_] := Span /@ SequencePosition[row, pattern[letters]]
pattern[letters_] := Alternatives[#, Reverse[#]] &[Alternatives[#, Style[#, ___]] & /@ letters]

Grid[
Fold[highlightString, listAll, {"MATHEMATICA", "USER", "STACK", "EXCHANGE"}],
Background -> LightBrown, Frame -> True
]


Note: The grid of letters in the OP contains letters such as "A ", and "M ", with spaces in them. To fix this, run

listAll = Map[StringTrim, listAll, {2}];

• By my interpretation this is incorrect on the diagonals, e.g. highlightString[listAll, "EHAARM"] should not do what it does. Aug 22, 2016 at 22:45
• @Mr.Wizard Well, I knew about this but I consider it very unlikely that it finds a spurious word in that way. As a solution, if it's a problem, I would suggest padding the grid. Aug 22, 2016 at 22:48
• Is there some reason not to generate only the existent diagonals? Aug 22, 2016 at 22:48
• @Mr.Wizard It's a side effect, I guess, of my tendency to look for pretty implementations first, and robust solutions second. I'm not sure that I can do what you suggest in an equally concise way. I haven't looked into it though. Aug 22, 2016 at 22:52
• Just to match my question: USERS instead of USER. Aug 23, 2016 at 0:19

Update

To allow string with multiple words separated by single space, and possible multiple instances of word and non empty intersection of positions:

mv[p_, sl_, m_] :=
Module[{d = Dimensions[m],
ms = Tuples[{-1, 0, 1}, 2] /. {0, 0} :> Sequence[],
ps, rule},
ps = If[
Or[Min[p + (sl - 1) #] <= 0, Min[d - (p + (sl - 1) #)] < 0], {},
Table[p + j #, {j, 0, sl - 1}]] & /@ ms;
rule = StringJoin[Extract[m, #]] -> # & /@ (ps /. {} -> Sequence[])
]
wf[str_, m_] := Module[{ss = StringSplit[str], fl, ru, find},
fl = {StringLength@#, Position[m, StringTake[#, 1]]} & /@ ss;
ru = Flatten[
Map[Function[u, Flatten[mv[#, u[[1]], m] & /@ u[[2]]]], fl]];
find = DeleteDuplicates@
Flatten[Map[Function[v, (v /. #) & /@ ru], ss] /.
Grid[MapAt[Style[#, Red, Bold] &, m, find], Frame -> True,
Background -> LightGray]
]


So: wf["MATHEMATICA STACK EXCHANGE USERS", mat]

mv[p_, sl_, m_] :=
Module[{d = Dimensions[m],
ms = Tuples[{-1, 0, 1}, 2] /. {0, 0} :> Sequence[],
ps, rule},
ps = If[
Or[Min[p + (sl - 1) #] <= 0, Min[d - (p + (sl - 1) #)] < 0], {},
Table[p + j #, {j, 0, sl - 1}]] & /@ ms;
rule = StringJoin[Extract[m, #]] -> # & /@ (ps /. {} -> Sequence[])
]
fun[str_, m_] :=
Module[{dim = Dimensions[m], sl = StringLength[str], pos, cand, r,
find},
pos = Position[m, StringTake[str, 1]];
r = Flatten[mv[#, sl, m] & /@ pos];
find = str /. r;
If[find == str, find = {}];
Grid[MapAt[Style[#, Red, Bold] &, m, find], Frame -> True]
]


mv searches grid only when string length possible fun returns result.

For example (note I had to remove spaces from copy and paste):

Using:

mat = {{"M", "S", "T", "A", "S", "I", "S", "X", "X", "T", "R", "X"},
{"A", "T", "H", "X", "R", "X ", "G", "R", "S", "H", "X", "A"},
{"M", "A", "T", "H", "E", "M", "A", "T", "I", "C", "A", "I"},
{"A", "X", "S", "G", "S", "X", "A", "I", "R", "T", "X", "T"},
{"T", "I", "T", "G", "U", "C", "C", "I", "R", "N", "X", "A"},
{"T", "A", "S", "X", "K", "G", "X", "H", "X", "A", "R", "C"},
{"H", "E", "R", "S", "I", "S", "G", "X", "A", "C", "E", "C"},
{"E", "H", "T", "H", "T", "I", "A", "T", "X", "N", "X", "X"},
{"S", "H", "H", "S", "R", "S", "X", "X", "S", "X", "G", "X"},
{"S", "G", "A", "S", "T", "A", "E", "G", "A", "G", "X", "E"}};


then

Column[fun[#, mat] & /@ {"MATHEMATICA", "STACK", "EXCHANGE"}]


yields:

and for "completeness":

A recursive approach that starts from each occurrence of the first character of each word and then searches in all possible directions for the complete word.

(* Returns lists of points that make up a word in words. *)
findWordsInMatrix[words_, matrix_] :=
Module[{characters, characterAssociation, wordsInMatrix},
characters = StringPartition[#, 1] & /@ words;
characterAssociation =
Merge[MapIndexed[StringTrim@#1 -> #2 &, matrix, {2}], Identity];
wordsInMatrix = findWord[#, characterAssociation] & /@ characters;
wordsInMatrix
];

(* Starts from all occurrences of the first character in a word, and \
initiates a search in all directions. *)
findWord[characters_, characterAssociation_] :=
Module[{firstCharacterPositions, directions, possiblePaths, paths},
firstCharacterPositions =
Lookup[characterAssociation, First@characters, {}];
directions = Cases[Tuples[{0, 1, -1}, 2], Except[{0, 0}]];
possiblePaths = Tuples[{firstCharacterPositions, directions}];
paths =
traceWord[First@#, Last@#, characters,
characterAssociation, {}] & /@ possiblePaths;
Select[paths, Length@# == Length@characters &]
];

(* Follows a certain direction recursively until the word has been \
found or the direction can be dismissed. *)
traceWord[position_, direction_, characters_, characterAssociation_,
trace_] :=
Module[{remainingCharacters = Rest@characters, possibleNextPosition,
path},
possibleNextPosition = position + direction;
path = Append[trace, position];
If[Length@remainingCharacters > 0 &&
MemberQ[Lookup[characterAssociation,
First@remainingCharacters, {}], possibleNextPosition],
path =
traceWord[possibleNextPosition, direction, remainingCharacters,
characterAssociation, path],
Nothing
];
path
];


Use the findWordsInMatrix function like this:

wordList = {"MATHEMATICA", "NULL", "STACK", "EXCHANGE", "NULL",
"USERS", "NULL"};
characterPositions =
Level[findWordsInMatrix[wordList, listAll], {-2}] //. {} ->
Sequence[];
Grid[MapAt[Style[#, Red, Bold] &, listAll, characterPositions],
Frame -> True, Background -> LightGray]


If you have a list of words and would like to know which of the words appear in the matrix there are several options. One is to count the number of occurrences of each word and then select those that appear at least once.

wordCount = Length /@ findWordsInMatrix[wordList, listAll]
{1, 0, 1, 1, 0, 1, 0}

Pick[wordList, wordCount, _?(# >= 1 &)]
{"MATHEMATICA", "STACK", "EXCHANGE", "USERS"}

• What an elegant solution! I am trying to understand all the steps and I think I got most of it, so much that I can say it is an elegant solution. The list here contains only four words, but suppose we have 100 words to test. Is it possible to print all the words that the program finds? I can substitute this list with a long one, but cannot print the list of found words. Thank you very much in advance.
– JSP
Jan 10, 2018 at 15:11
• @JSP Thanks, I took another look at it. I found a bug and rewrote it from scratch but using the same strategy, hopefully it's more readable now. I added an example at the end of how to list the words that were found.
– V.E.
Jan 12, 2018 at 2:09
• Very nice, thank you. As a matter of fact, your former program finds words that change direction (like a worm), but this one seems to find only along lines. I am unable to understand where the two programs diverge so that it can find CIRANTA.
– JSP
Jan 13, 2018 at 17:55
• @JSP Yes, exactly. That's the "bug" I was referring to. The first version considers ALL directions at each step, while the new version considers all directions initially and then follows each direction after the first step. I did not think that it was the desired behavior!
– V.E.
Jan 13, 2018 at 21:15
• yes it was but I did not mention it because the former program did it quite well. Also, if you have the time, could you explain the code line that starts with "characterPositions=Level..." I cannot fully understand the -2, the empty list etc. Thank you.
– JSP
Jan 13, 2018 at 22:37