Solving word search puzzles

Question

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

Answer 1

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}];

Answer 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":

Answer 3

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