Solving word search puzzles
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}];
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] /.
Thread[ss :> Sequence[]], 2];
Grid[MapAt[Style[#, Red, Bold] &, m, find], Frame -> True,
Background -> LightGray]
]
So: wf["MATHEMATICA STACK EXCHANGE USERS", mat]
Original Answer
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"}