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
 ]

Mathematica graphics

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]

enter image description here

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:

enter image description here

and for "completeness":

enter image description here


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"}