21
$\begingroup$

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

$\endgroup$
  • 1
    $\begingroup$ 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. $\endgroup$ – march Aug 22 '16 at 20:13
  • $\begingroup$ 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 + ... $\endgroup$ – LCarvalho Aug 22 '16 at 20:29
  • $\begingroup$ 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) $\endgroup$ – george2079 Aug 22 '16 at 20:30
  • $\begingroup$ Or as an image with the words highlighted. Not necessarily as an animation. $\endgroup$ – LCarvalho Aug 22 '16 at 20:35
  • 1
    $\begingroup$ Related: (5387) $\endgroup$ – Mr.Wizard Aug 22 '16 at 22:25
23
$\begingroup$

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}];
$\endgroup$
  • $\begingroup$ By my interpretation this is incorrect on the diagonals, e.g. highlightString[listAll, "EHAARM"] should not do what it does. $\endgroup$ – Mr.Wizard Aug 22 '16 at 22:45
  • $\begingroup$ @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. $\endgroup$ – C. E. Aug 22 '16 at 22:48
  • $\begingroup$ Is there some reason not to generate only the existent diagonals? $\endgroup$ – Mr.Wizard Aug 22 '16 at 22:48
  • $\begingroup$ @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. $\endgroup$ – C. E. Aug 22 '16 at 22:52
  • $\begingroup$ Just to match my question: USERS instead of USER. $\endgroup$ – LCarvalho Aug 23 '16 at 0:19
14
$\begingroup$

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

$\endgroup$
6
$\begingroup$

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"}
$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – JSP Jan 10 '18 at 15:11
  • $\begingroup$ @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. $\endgroup$ – V.E. Jan 12 '18 at 2:09
  • $\begingroup$ 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. $\endgroup$ – JSP Jan 13 '18 at 17:55
  • $\begingroup$ @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! $\endgroup$ – V.E. Jan 13 '18 at 21:15
  • $\begingroup$ 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. $\endgroup$ – JSP Jan 13 '18 at 22:37

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.