字谜Mathematica中使用模式匹配

Question

假如我选择了数学词典所有3次字符的话：

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

，我想形成全拼字游戏般的套，比如：

A B E 
R A Y 
E R E 

凡单词可以水平和垂直读取。

显然，可以通过递归和回溯找到这些集合。但是：

1）有没有办法使用模式来解决它？
2）哪些维度有有效的解决方案？

编辑

我写的问题，为DictionaryLookup[]只是因为它的可变长度记录的合理大小的数据库。我真正的问题与字典查找无关，而是与某种织机模式有关。

Answer 1

我不知道你是否会考虑根据以下方法模式 - 但它的工作原理，它可以想见扩展到许多方面，虽然与all3数据集，它可能会KONK出相当早......

的想法是启动一个空白填字：

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

，然后递归执行以下操作：对于一个给定的模式，看看ro WS反过来，扩大与最少数量的匹配的行模式（填写任何恰好与一个完成后）：

(* 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]]]]]]; 

对于给定的候选模式，尝试沿两个维度的完成和保持一个能产生最少的：

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

我做递归广度第一个能够使用联盟，但深度可能首先用于更大的问题是必要的。性能是马马虎虎：8笔记本分钟才找到在例题中116568场比赛：

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 

原则上，应该可以递归到这个更高的维度，即使用替代词表的填字游戏名单尺寸3.如果列表长度与列表中的模式匹配的时间是线性的，那么对于100000个以上尺寸的单词列表，这将非常慢...

Answer 2

另一种方法是使用SatisfiabilityInstances，约束指定每行和每列必须是有效的单词。下面的代码需要40秒才能获得使用200个三字母词典的前5个解决方案。您可以用SatisfiabilityCount替换SatisfiabilityInstances以获得这些填字游戏的数量。

setupCrossword[wordStrings_] := (
    m = Length[chars]; 

    words = Characters /@ wordStrings; 
    chars = Union@Flatten@words; 

    wordMatch[vars_, word_] := And @@ (Thread[{vars, word}]); 
    validWord[vars_] := Or @@ (wordMatch[vars, #] & /@ words); 
    validCell[{i_, j_}] := 
    BooleanCountingFunction[{1}, {{i, j}, #} & /@ chars]; 

    row[i_] := {i, #} & /@ Range[n]; 
    col[i_] := {#, i} & /@ Range[n]; 
    cells = Flatten[row /@ Range[n], 1]; 

    rowCons = validWord[row[#]] & /@ Range[n]; 
    colCons = validWord[col[#]] & /@ Range[n]; 
    cellCons = validCell /@ cells; 
    formula = And @@ (Join[rowCons, colCons, cellCons]); 
    vars = 
    Table[{{i, j}, c}, {i, 1, n}, {j, 1, n}, {c, chars}] // 
    Flatten[#, 2] &; 
    decodeInstance[instance_] := (
    choices = Extract[vars, Position[instance, True]]; 
    grid = Table[{i, j}, {i, 1, n}, {j, 1, n}] /. Rule @@@ choices 
    ) 
    ); 

n = 3; 
wordLimit = 200; 
wordStrings = 
    Select[DictionaryLookup[], 
    StringLength[#] == n && LowerCaseQ[#] &]; 
setupCrossword[wordStrings[[;; wordLimit]]]; 

vals = SatisfiabilityInstances[formula, vars, 5]; 
Framed@TableForm@decodeInstance@# & /@ vals 

http://yaroslavvb.com/upload/save/crosswords.png

这种方法使用变量，如{{i,j},"c"}指示细胞{i,j}得到字母 “C”。每个单元格受约束只能得到一个字母BooleanCountingFunction，每行和每列都被约束成一个有效的单词。例如，约束第一行必须是“王牌”或“ - ”看起来像这样

{{1,1},"a"}&&{{1,2},"c"}&&{{1,3},"e"}||{{1,1},"b"}&&{{1,2},"a"}&&{{1,3},"r"}