Word Squares and Beyond

Question

A word square is a set of words which, when placed in a grid, read the same horizontally and vertically. For example, the following is an English word square of order 5:

F A C E D
A L I V E
C I V I L
E V I C T
D E L T A

A word cube is an extension of this idea into three dimensions. For example, here are the slices of a word cube of order 4:

H A N D    A R E A    N E T S    D A S H
A R E A    R E A L    E A R L    A L L Y
N E T S    E A R L    T R I O    S L O P
D A S H    A L L Y    S L O P    H Y P E

Imagine stacking these squares vertically to form a cube; then notice how each the nth vertical slice is the same as the nth horizontal slice, and both are word squares.

This idea can be extended into word hypercubes, but for simplicity, let's keep the dimensions to 2 or 3.

How can we use Mathematica to generate word squares and word cubes? This is a difficult combinatorics question, so I'm only looking for a function which can generate word squares and word cubes of small order in a reasonable amount of time.

related http://stackoverflow.com/questions/4867712/crosswords-in-mathematica-using-pattern-matching — Dr. belisarius, Aug 05 '12 at 23:56
Neat idea, but I can't help wanting to cite the StackExchange perennial: "What have you tried?". Also related: http://codereview.stackexchange.com/questions/12974/word-square-generation-in-python. Wikipedia tells me that there isn't currently a known order-10 word square, so small order is as far as it goes. — Verbeia, Aug 06 '12 at 00:04
Collection of programs in other languages: http://www.gtoal.com/scrabble/wordsquares.html — Vitaliy Kaurov, Aug 06 '12 at 00:29
@Verbeia I haven't tried anything yet. I'm not as interested in having a solution to the problem as I am in seeing how expert Mathematica users would approach it. As you pointed out, this problem becomes quickly intractable, so I'm not looking for solutions whose asymptotic running time remarkable, but rather clever ways to utilize Mathematica's toolbox to solve the problem with not too many lines of code. — Zach Langley, Aug 06 '12 at 01:50
While this is not the same thing, this question and its answers might be of interest to you: http://mathematica.stackexchange.com/questions/5387/using-mathematicas-graph-functions-to-cheat-at-boggle/ — rm -rf, Aug 06 '12 at 11:20

Rojo · Accepted Answer · 2012-08-07T01:41:33.477

My solution

ClearAll[findWordHypercube];
Begin["`findWordHypercube`"];
ClearAll[inspect, nextIndices, indices, tag];
Options[findWordHypercube] = {"Random" -> True};
findWordHypercube[dims_Integer, len_Integer, op : OptionsPattern[]] :=
  findWordHypercube[ConstantArray[_, len~ConstantArray~dims], op]
findWordHypercube[mat_, OptionsPattern[]] := 
  Block[{$random = 
         If[OptionValue["Random"], RandomSample, 
          Identity], $RecursionLimit = Infinity, $IterationLimit = 
     Infinity, dictCache}, Catch[inspect[mat] =!= Null, tag]];

dict[numLetters_] := Replace[dictCache[numLetters],
 _dictCache :> (dictCache[numLetters] = 
   DictionaryLookup[Repeated[_, {numLetters}]])];

(* does the search *) 
inspect[mat_] := inspect[mat, nextIndices[mat]]

(* finds the indices of the next word to try *) 
nextIndices[mat_] /; FreeQ[mat, Verbatim@_] := True
nextIndices[mat_] := nextIndices[mat, indices[mat]]

(* gives all the different groups of positions of words of a matrix \
of a certain size. They are grouped by those that must be the same \
due to the required symmetry *) 
i : indices[wordLen_, dims_] := 
  i = Permutations[Append[#, All]] & /@ 
    DeleteDuplicates[Sort /@ Tuples[Range[wordLen], {dims - 1}]];
indices[mat_] := indices[Length@mat, Length@Dimensions@mat];

nextIndices[mat_, indices_] := 
 nextIndices[mat, indices, 
  1 + LengthWhile[indices[[All, 1]], 
    FreeQ[mat[[Sequence @@ #]], Verbatim@_] &]]
nextIndices[mat_, indices_, nextIndex_] := Extract[indices, nextIndex];

inspect[mat_, True] := Throw[mat, tag];
inspect[mat_, indices_] := 
 Scan[word \[Function] inspect[change[mat, word, indices]], 
  Characters@$random@
    Pick[#, StringMatchQ[#, 
      StringExpression @@ mat[[Sequence @@ First@indices]]]] &@
        dict[Length@mat]]

(* adds the word (as list of characters) to the matrix *) 
change[mat_, word_, indices_] := 
 Module[{newMat = mat}, 
  Scan[wordPos \[Function] newMat[[Sequence @@ wordPos]] = word, 
   indices];
  newMat]

 End[];

findWordHypercube can take the dimensions as first argument and the word length as a second. It can also take a partially solved matrix with _ in the places that are still to fill (it assumes it has been properly partially filled). It takes the option "Random", that defaults to True, to know whether it will give a random result or a deterministic one. It returns False when there are no solutions. It uses DictionaryLookup in the default language to find the words

findWordHypercube[2, 4]
findWordHypercube[2, 4]

{{"y", "e", "l", "p"}, {"e", "v", "i", "l"}, {"l", "i", "c", "e"}, {"p", "l", "e", "b"}}

{{"m", "a", "w", "s"}, {"a", "w", "a", "y"}, {"w", "a", "i", "n"}, {"s", "y", "n", "c"}}

+1 Very nice. Can you pin point in a few words the main algorithm difference between your solution and the one that starts with an initial string/word (like @Verbeia) ? I think it is still possible to enumerate your pseudo-random solutions with something like (SeedRandom[#]; findWordHypercube[2, 3, "Random" -> True]) & /@ Range[10] — Vitaliy Kaurov, Aug 06 '12 at 20:33
@VitaliyKaurov I haven't actually looked at Verebia's solution, but to see that it still didn't solve the most general case. Didn't have the time yet, but I plan to later. I can describe this solution if you want and you do the comparison — Rojo, Aug 06 '12 at 20:38
Pretty good, but doesn't quite work as advertised when a partial solution is provided. Start with a known solution: findWordHypercube[2, 3] (* {{"m", "u", "d"}, {"u", "n", "i"}, {"d", "i", "g"}} *), then try with the bottom left filled in: findWordHypercube@{{_, _, _}, {_, _, _}, {"d", _, _}} (*{{"v", "e", "t"}, {"e", "r", "r"}, {"t", "r", "y"}}*). Where's my "d"? — wxffles, Aug 06 '12 at 20:42
@wxffles, probably it doesn't work as advertised, but that is not a counterexample. The docs said "it assumes it has been properly partially filled". You need to ask yourself what that means — Rojo, Aug 06 '12 at 20:43
Hehe, in this case it means that if you put your "d" there, it should also be put in all other places that you already know there must be a "d" — Rojo, Aug 06 '12 at 20:43
I could do that automatically, or add a function that checks if it's possible to do or the matrix is already doomed. Or anyone else can do it and edit it in... — Rojo, Aug 06 '12 at 20:44

Verbeia · Answer 2 · 2012-08-06T04:14:39.027

Here is a brute-force algorithm for four-letter word squares (not cubes) that takes about a second on a three-year-old laptop.

findWordSquare[first_String] /; StringLength[first] == 4 := 
 Module[{words = Select[DictionaryLookup[{"English", All}], 
     StringLength[#] == 4 &], secondlist, thirdlist, 
   f2 = StringTake[first, {2}], f3 = StringTake[first, {3}], f4 = StringTake[first, {4}]}, 
  secondlist = Flatten[StringCases[words, 
      f2 ~~ LetterCharacter ~~ LetterCharacter ~~ LetterCharacter] /. {} -> Sequence[]];
  thirdlist = DeleteCases[{#, Flatten[StringCases[words, 
      f3 ~~ StringTake[#, {3}] ~~ LetterCharacter ~~ 
      LetterCharacter] /. {} -> Sequence[]]} & /@ secondlist, {_, {}}];
  Flatten[Table[{first, #1, #2, #3[[i]]}, {i, Length[#3]}] & @@@ 
   Flatten[(DeleteCases[Table[{#[[1]], #[[2, i]], 
     Flatten[StringCases[words, 
      f4 ~~ StringTake[#[[1]],{4}] ~~ StringTake[#[[2, i]],{4}] ~~ LetterCharacter] /. 
 {} ->  Sequence[]]}, {i, Length[#[[2]]]}], {__, {}}] & /@  thirdlist), 1], 1]]

The output is a list of solutions given the first word.

EDIT
Here is a version for five-letter words. I have been unable to work out a simple generalisation to avoid coding them up separately. This takes about 40 seconds on my machine, compared with a couple of seconds for four-letter words. There are actually 76 squares starting with "faced".

findWordSquare[first_String] /; StringLength[first] == 5 := 
 Module[{words = 
    Select[DictionaryLookup[{"English", All}], 
     StringLength[#] == 5 &], secondlist, thirdlist, fourthlist, 
   f2 = StringTake[first, {2}], f3 = StringTake[first, {3}], 
   f4 = StringTake[first, {4}], f5 = StringTake[first, {5}]}, 
  secondlist = Flatten[StringCases[words, 
    f2 ~~ LetterCharacter ~~ LetterCharacter ~~ LetterCharacter ~~ 
     LetterCharacter] /. {} -> Sequence[]];
  thirdlist = DeleteCases[{#, Flatten[StringCases[words, 
    f3 ~~ StringTake[#, {3}] ~~ LetterCharacter ~~ 
     LetterCharacter ~~ LetterCharacter] /. {} -> Sequence[]]} & /@ secondlist, {_, {}}];
  fourthlist = Flatten[Table[{#1, #2, #3[[i]]}, {i, Length[#3]}] & @@@ 
     Flatten[(DeleteCases[Table[{#[[1]], #[[2, i]], 
      Flatten[StringCases[words, f4 ~~ StringTake[#[[1]], {4}] ~~ 
        StringTake[#[[2, i]], {4}] ~~ LetterCharacter ~~ 
        LetterCharacter] /. {} -> Sequence[]]}, {i, Length[#[[2]]]}], {__, {}}] 
     & /@ thirdlist), 1], 1];
  Flatten[Table[{first, #1, #2, #3, #4[[i]]}, {i, Length[#4]}] & @@@ 
   DeleteCases[({#[[1]], #[[2]], #[[3]], 
    Flatten[StringCases[words, f5 ~~ StringTake[#[[1]], {5}] ~~ StringTake[#[[2]], {5}] ~~
      StringTake[#[[3]], {5}] ~~ LetterCharacter]]} & /@ fourthlist), {__, {}}], 1]]

+1 Lovely! Here is the usage for the initial string "true" that generates just 8 squares Grid[#, Frame -> All] & /@ Characters /@ findWordSquare["true"] with just total of 11 different words Union@Flatten@findWordSquare["true"] I wonder which words produce the least number of squares. — Vitaliy Kaurov, Aug 06 '12 at 01:34
@VitaliyKaurov there are four-letter words with no solutions, e.g. "ibex". — Verbeia, Aug 06 '12 at 01:40
Yep, exactly what I was looking for ;-) Do you get a tremendous slowdown for 5 letter strings? — Vitaliy Kaurov, Aug 06 '12 at 01:53
@VitaliyKaurov - haven't tried yet. I haven't thought of a way to generalise the above code, only to have separate cases for each string length. And I doubt word cubes can be done in only a few lines of code. — Verbeia, Aug 06 '12 at 03:17
I think there is actually a general solution involving Fold for word squares of different lengths, but I am getting myself confused with too much nested Slot notation. Maybe someone else wants to have a go. — Verbeia, Aug 06 '12 at 04:14

Peter Burbery · Answer 3 · 2022-05-16T01:34:50.343

I have created a function that is very complicated but gets the job done.

WordSquaresGenerator[str_] := 
 Block[{char1, char2, char3}, char1 = StringPart[str, 2]; 
  char2 = StringPart[str, 3]; char3 = StringPart[str, 4]; 
  Grid[List /@ Join[{str}, #]] & /@ 
   Flatten[Function[word, 
      Join[{word[[1]], word[[2]], #}] & /@ 
       Select[DictionaryLookup[char3 ~~ _ ~~ _ ~~ _], 
        StringPart[#, 2] == StringPart[word[[1]], 4] && 
          StringPart[#, 3] == StringPart[word[[2]], 4] &]] /@ 
     Select[Select[
       Tuples[{DictionaryLookup[char1 ~~ _ ~~ _ ~~ _], 
         DictionaryLookup[char2 ~~ _ ~~ _ ~~ _]}], 
       StringPart[#[[1]], 3] == StringPart[#[[2]], 2] &], 
      Function[word, 
       Select[DictionaryLookup[char3 ~~ _ ~~ _ ~~ _], 
         StringPart[#, 2] == StringPart[word[[1]], 4] && 
           StringPart[#, 3] == StringPart[word[[2]], 4] &] != {}]], 
    1]]

I asked this question because of a Wolfram Challenge. I have posted my Wolfram Challenge solutions at https://github.com/PeterCullenBurbery/Wolfram-Challenges

Word Squares and Beyond

3 Answers3

Linked