Crosswords in Mathematica using Pattern Matching

Question

Suppose I select all 3 char words from the Mathematica dictionary:

all3 = Characters /@ Select[DictionaryLookup[], StringLength[#] == 3 &];  

and I want to form full scrabble-like sets, like:

A B E
R A Y
E R E  

Where the words can be read horizontally and vertically.

Clearly, the sets can be found with recursion and backtracking. But:

1) Is there a way to solve it using patterns?
2) For which dimensions are there valid solutions?

Edit

I wrote the question for DictionaryLookup[] just because it's a reasonable sized database of variable length records. My real problem is not related to Dictionary lookups but to a certain kind of loom patterns.

Answer 1

I am not sure if you would consider the following approach pattern based -- but it works, and it can conceivably be extended to many dimensions, although with the all3 dataset, it would probably konk out rather early...

The idea is to start with a blank crossword:

blankCW={{_,_,_},{_,_,_},{_,_,_}};

and then recursively do the following: For a given pattern, look at the rows in turn and (after filling out any with exactly one completion) expand the pattern on the row with the fewest number of matches:

(* Cache the number of matches for a given pattern *)
nmatch[patt_]:=nmatch[Verbatim@patt]=Length@Cases[all3,patt]

(* A helper to fill single matches if needed *)
fixone[ml_,nl_]:=If[FreeQ[ml[[nl]],Verbatim[_]],ml, 
  ReplacePart[ml, nl->First@Cases[all3,ml[[nl]]]]];

findCompletions[m_]:=Module[{nn,ur},
  (* Pattern w/ filled single matches -> ur, ordering by # of matches -> nn *)
  {ur,nn}=NestWhile[{fixone[#[[1]],First@#[[2]]], Rest@#[[2]]}&,
    {m,Ordering[nmatch/@m]},
    (Length[#[[2]]]>0&&nmatch@#[[1,#[[2,1]]]]==1)&];

  (* Expand on the word with the fewest number og matches *)
  If[Length[nn]==0,{ur},
    With[{n=First@nn},ReplacePart[ur,n-> #]&/@Cases[all3,ur[[n]]]]]];

For a given candidate pattern, try out the completion along both dimensions and keep the one that yield the fewest:

findCompletionsOriented[m_]:=Module[{osc},
  osc=findCompletions/@Union[{m,Transpose@m}];
  osc[[First@Ordering[Length/@osc,1]]]]

I do the recursion breadth first to be able to use Union, but depth first might be necessary for bigger problems. Performance is so-so: 8 laptop minutes to find the 116568 matches in the example problem:

Timing[crosswords=FixedPoint[Union[Join@@(findCompletionsOriented/@#)]&,{blankCW}];]
Length@crosswords
TableForm/@Take[crosswords,5]

Out[83]= {472.909,Null}
Out[84]= 116568
          aah aah aah aah aah
Out[86]={ ace ace ace ace ace }
          hem hen hep her hes

In principle, it should be possible to recurse this into higher dimensions, i.e. using the crosswords list instead of the wordlist for dimension 3. If the time to match a pattern against a list is linear in the list-length, this would be quite slow with a 100000+ sized wordlist...