3
$\begingroup$

This table with a caption that said "First three words you see will come to you in 2021" inspired me to do some digging:

Imagine that we have a table with randomly filled letters. How can Mathematica identify the words inside that table? I wrote these lines:

minWordLength = 3; (* Declare the minimum length of a word *)

substrings[str_String, len_:minWordLength] := With[{r = StringLength[str]},
  Join@@ Table[StringTake[str, {i, j}], {i, r+1}, {j, i+len-1, r}] ];

highlights[str_String] := With[{pos =
  Union@@ (Range@@ (Flatten[#, 1]&)@ StringPosition[str, #]&/@
  Select[substrings[str], DictionaryWordQ[#, IgnoreCase-> True]&] )},
  MapIndexed[If[MemberQ[pos, First@ #2], Style[#, Red], #]&, Characters@str] ] ;

findwords[table_] := With[{list = If[StringQ@table,
  StringPartition[ToUpperCase@table, Sqrt@StringLength@table],
  ToUpperCase/@ table]},
  Grid[highlights/@ list, Frame-> All] ];

As you see, the argument of findwords can either be a string containing all the letters inside the table, or a list of strings that contain the letters in each row. This code highlights the words found in the dictionary with red color. For example, if we write:

str = StringJoin@ RandomChoice[CharacterRange["a", "z"], 256];
findwords[str]

then the result will be something like this:

output of the code

Now there are several issues with this code that I cannot figure out how to solve. I'll appreciate any help.

  1. Sometimes there are a few seemingly gibberish words highlighted in the table. Some of them appear to be abbreviations. For example, as you see in the above picture, LLL or XXV or LII are not actual words. I wasn't able to get rid of these, because DictionaryWordQ doesn't have any options to specify which kind of words we are seeking. Is there any way to filter those?
  2. This code can only find horizontal words. Can we modify it to find vertical words as well? (Maybe highlighted with another color). I struggled a bit with the idea of transposing the table and then doing the same process on transposed table. But the process became way too complicated and furthermore, I wasn't able to highlight the resulting vertical words alongside the horizontal ones. Is there some kind of a neat trick to do this?
  3. And as a bonus point, what about diagonal words? For this one I had no clue, not even a tiny one.
$\endgroup$
9
  • $\begingroup$ "what about diagonal words" - have you tried using Diagonal[]? $\endgroup$
    – J. M.'s torpor
    Jan 2 at 18:50
  • $\begingroup$ @J.M. yes I have. But then again, finding the indices and then highlighting them became a real headache. $\endgroup$
    – polfosol
    Jan 2 at 18:51
  • $\begingroup$ Not identical but overlapping (5387). $\endgroup$
    – Pillsy
    Jan 2 at 19:15
  • $\begingroup$ @C.E. in that question, we know what words we are looking for. Here we don't $\endgroup$
    – polfosol
    Jan 3 at 3:50
  • 1
    $\begingroup$ This question is closed as a duplicate of "Solving word search puzzles" because of question's somewhat misleading title. I do not see finding the words as the primary (or only) challenge in the question. I think the requests for quality and display of the results are not answered in "Solving word search puzzles" . $\endgroup$ Jan 3 at 14:38
5
$\begingroup$

Updated answer

As a follow up question, can we apply a different strategy for distinguishing the words? For example, adding a frame instead of coloring them.

Answering the follow up question does bring better looking and easier to read results:

aResFr =
  findwords[str, CommonWordQ,
   <|Horizontal -> (Framed[Style[#, Blue, Bold], 
        Background -> Yellow] &),
    Vertical -> (Framed[Style[#, Red], Background -> LightBlue] &),
    Diagonal -> (Framed[Style[#, Purple, Bold], 
        Background -> GrayLevel[0.9]] &)|>];
Grid[#, Dividers -> All] & /@ aResFr

enter image description here

Grid[CombineHighlights[aResFr], Dividers -> All]

enter image description here

The update definitions below are based on the definitions of the first answer with some relatively small code refactoring. The function signatures have to be "relaxed" to take "highlighter function" as an argument.

Definitions

(*Declare the minimum length of a word*)
minWordLength = 3;

ClearAll[substrings];
substrings[str_String, len_ : minWordLength] :=
  
  Block[{r = StringLength[str]},
   Join @@ Table[StringTake[str, {i, j}], {i, r + 1}, {j, i + len - 1, r}]
   ];

ClearAll[wordsFinder];
wordsFinder[str_String, dictWordFunc_ : DictionaryWordQ, 
   highlighterFunc_ : (Style[#, Red] &)] :=
  Block[{pos, res},
   pos = Union @@ (Range @@ (Flatten[#, 1] &)@StringPosition[str, #] & /@ 
       Select[substrings[str], dictWordFunc[#, IgnoreCase -> True] &]);
   MapIndexed[If[MemberQ[pos, First@#2], highlighterFunc[#], #] &, 
    Characters@str]
   ];

ClearAll[highlightsDiag];
highlightsDiag[str_String, dictWordFunc_ : DictionaryWordQ, 
   highlighterFunc_ : (Style[#, Red] &)] :=
  
  Block[{matChars, n, matInds, res},
   matChars = Partition[Characters@str, Sqrt[StringLength[str]]];
   n = Length[matChars];
   matInds = Table[{i, j}, {i, n}, {j, n}];
   res = Table[
     AssociationThread[Diagonal[matInds, i], 
      wordsFinder[StringJoin @@ Diagonal[matChars, i], dictWordFunc, 
       highlighterFunc]], {i, -n + 1, n - 1}];
   Normal[SparseArray[Normal[Join @@ res]]]
   ];

ClearAll[highlights];
highlights[str_String, dir_, dictWordFunc_ : DictionaryWordQ, 
   highlighterFunc_ : (Style[#, Red] &)] :=
  
  Block[{matChars, n, matInds, res},
    matChars = Partition[Characters@str, Sqrt[StringLength[str]]];
    If[TrueQ[dir === Vertical],
     matChars = Transpose[matChars]
     ];
    n = Length[matChars];
    matInds = Table[{i, j}, {i, n}, {j, n}];
    res = Table[
      AssociationThread[matInds[[i]], 
       wordsFinder[StringJoin @@ matChars[[i]], dictWordFunc, 
        highlighterFunc]], {i, n}];
    res = Normal[SparseArray[Normal[Join @@ res]]];
    If[TrueQ[dir === Vertical],
     Transpose[res],
     (*ELSE*)
     res
     ]
    ] /; MemberQ[{Vertical, Horizontal}, dir];

ClearAll[findwords];
findwords[table_, dictWordFunc_ : DictionaryWordQ, 
   highlighterFunc_ : (Style[#, Red] &), opts : OptionsPattern[]] :=
  
  Block[{str},
    str = If[MatrixQ[table], StringJoin @@ Flatten[table], table];
    str = ToUpperCase[str];
    <|
     
     "Horizontal" -> 
      highlights[str, Horizontal, dictWordFunc, 
       If[AssociationQ[highlighterFunc], highlighterFunc[Horizontal], 
        highlighterFunc]],
     "Vertical" -> 
      highlights[str, Vertical, dictWordFunc, 
       If[AssociationQ[highlighterFunc], highlighterFunc[Vertical], 
        highlighterFunc]],
     "Diagonal" -> 
      highlightsDiag[str, dictWordFunc, 
       If[AssociationQ[highlighterFunc], highlighterFunc[Diagonal], 
        highlighterFunc]]
     |>
    ] /; (SquareMatrixQ[table] || StringQ[table]);

Clear[CombineHighlights];
CombineHighlights[aTbls_Association] :=
  
  Map[If[VectorQ[#, StringQ], First[#], Last@Select[#, Not@*StringQ]] &, 
   Transpose[Values[aTbls], {3, 1, 2}], {2}];

Clear[CommonWordQ];
aCommonWords = 
  AssociationThread[ToLowerCase@Union[RandomWord["CommonWords", 10^6]], 
   True];
CommonWordQ[w_String, opts : OptionsPattern[]] := 
  Lookup[aCommonWords, ToLowerCase@w, False];

First answer

Here are brief descriptions of my way of answering OP's questions:

  1. We can define CommonWordQ function based on RandomWord["CommonWords"].

  2. One way to do it is to refactor OP's code:

    • Rename OP's highlights into wordsFinder.

    • Create functions for horizontal and vertical words highlights making them utilize rules for SparseArray.

  3. Diagonal words highlights are similar to the horizontal and vertical words highlights finding, but using Diagonal instead of Part.

Note, that:

  • I tried to reuse OP's code, as much as possible.

  • I combine the tables into one, but the results are hard to read.

  • Further refactoring can put other Style element, not just color.

  • The refactored functions take as arguments: string, is-it-a-word function, and color (or an association of colors).

Definitions

(*Declare the minimum length of a word*)
minWordLength = 3;

ClearAll[substrings];
substrings[str_String, len_ : minWordLength] :=  
  Block[{r = StringLength[str]},
   Join @@ 
    Table[StringTake[str, {i, j}], {i, r + 1}, {j, i + len - 1, r}]
   ];

ClearAll[wordsFinder];
wordsFinder[str_String, dictWordFunc_ : DictionaryWordQ, color_ : Red] :=
  Block[{pos, res},
    pos = 
     Union @@ (Range @@ (Flatten[#, 1] &)@StringPosition[str, #] & /@ 
        Select[substrings[str], 
         dictWordFunc[#, IgnoreCase -> True] &]);
    MapIndexed[If[MemberQ[pos, First@#2], Style[#, color], #] &, 
     Characters@str]
    ] /; ColorQ[color];

ClearAll[highlightsDiag];
highlightsDiag[str_String, dictWordFunc_ : DictionaryWordQ, color_ : Red] :=
  Block[{matChars, n, matInds, res},
    matChars = Partition[Characters@str, Sqrt[StringLength[str]]];
    n = Length[matChars];
    matInds = Table[{i, j}, {i, n}, {j, n}];
    res = 
     Table[AssociationThread[Diagonal[matInds, i], 
       wordsFinder[StringJoin @@ Diagonal[matChars, i], dictWordFunc, 
        color]], {i, -n + 1, n - 1}];
    Normal[SparseArray[Normal[Join @@ res]]]
    ] /; ColorQ[color];

ClearAll[highlights];
highlights[str_String, dir_, dictWordFunc_ : DictionaryWordQ, color_ : Red] :=
  Block[{matChars, n, matInds, res},
    matChars = Partition[Characters@str, Sqrt[StringLength[str]]];
    If[TrueQ[dir === Vertical],
     matChars = Transpose[matChars]
     ];
    n = Length[matChars];
    matInds = Table[{i, j}, {i, n}, {j, n}];
    res = 
     Table[AssociationThread[matInds[[i]], 
       wordsFinder[StringJoin @@ matChars[[i]], dictWordFunc, 
        color]], {i, n}];
    res = Normal[SparseArray[Normal[Join @@ res]]];
    If[TrueQ[dir === Vertical],
     Transpose[res],
     (*ELSE*)
     res
     ]
    ] /; MemberQ[{Vertical, Horizontal}, dir] && ColorQ[color];

ClearAll[findwords];
findwords[table_, dictWordFunc_ : DictionaryWordQ, color_ : Red, opts : OptionsPattern[]] :=
  Block[{str},
    str = If[MatrixQ[table], StringJoin @@ Flatten[table], table];
    str = ToUpperCase[str];
    <|
     
     "Horizontal" -> 
      highlights[str, Horizontal, dictWordFunc, 
       If[ColorQ[color], color, color[1]]],
     "Vertical" -> 
      highlights[str, Vertical, dictWordFunc, 
       If[ColorQ[color], color, color[2]]],
     "Diagonals" -> 
      highlightsDiag[str, dictWordFunc, 
       If[ColorQ[color], color, color[3]]]
     |>
    ] /; (SquareMatrixQ[table] || StringQ[table]);

Clear[CombineHighlights];
CombineHighlights[aTbls_Association] :=
  
  Map[If[VectorQ[#, StringQ], First[#], 
     Last@Select[#, Head[#] === Style &]] &, 
   Transpose[Values[aTbls], {3, 1, 2}], {2}];

Clear[CommonWordQ];
aCommonWords = AssociationThread[ToLowerCase@Union[RandomWord["CommonWords", 10^6]], True];
CommonWordQ[w_String, opts : OptionsPattern[]] := Lookup[aCommonWords, ToLowerCase@w, False];

Tables for dictionary words

str = StringJoin@RandomChoice[CharacterRange["a", "z"], 256];

Grid[#, Dividers -> All] & /@ findwords[str, DictionaryWordQ, Red]

enter image description here

Tables for common words

Grid[#, Dividers -> All] & /@ findwords[str, CommonWordQ, Red]

enter image description here

Combining the tables

Combining the tables does not look that good (in my opinion):

aRes3 = findwords[str, CommonWordQ, <|1 -> Red, 2 -> Blue, 3 -> Green|>];
Grid[CombineHighlights[aRes3], Dividers -> All]

enter image description here

$\endgroup$
2
  • $\begingroup$ Thanks. This is inarguably perfect already. As a follow up question, can we apply a different strategy for distinguishing the words? For example, adding a frame instead of coloring them. $\endgroup$
    – polfosol
    Jan 3 at 4:57
  • $\begingroup$ @polfosol Yes, but some refactoring has to be done. (Some of the function signatures have to be "relaxed" to take highlighter function as an argument.) See my update. $\endgroup$ Jan 3 at 14:22

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