Word Squares and Beyond

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.

-
– Dr. belisarius Aug 5 '12 at 23:56
Neat idea, but I can't help wanting to cite the StackExchange perennial: "What have you tried?". Also related: codereview.stackexchange.com/questions/12974/…. 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 6 '12 at 0:04
Collection of programs in other languages: gtoal.com/scrabble/wordsquares.html – Vitaliy Kaurov Aug 6 '12 at 0: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 6 '12 at 1:50
While this is not the same thing, this question and its answers might be of interest to you: mathematica.stackexchange.com/questions/5387/… – R. M. Aug 6 '12 at 11:20

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 6 '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 6 '12 at 20:38
No worries, you did pretty good job in comments ;-) – Vitaliy Kaurov Aug 6 '12 at 20:41
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 6 '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 6 '12 at 20:43

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 6 '12 at 1:34
@VitaliyKaurov there are four-letter words with no solutions, e.g. "ibex". – Verbeia Aug 6 '12 at 1:40
Yep, exactly what I was looking for ;-) Do you get a tremendous slowdown for 5 letter strings? – Vitaliy Kaurov Aug 6 '12 at 1: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 6 '12 at 3: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 6 '12 at 4:14