12

假设我从 Mathematica 字典中选择了所有 3 个字符词： 

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

我想形成完整的类似拼字游戏的集合，比如： 

A B E
R A Y
E R E

可以水平和垂直阅读单词的地方。

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

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

编辑

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

4

2 回答 2

11

我不确定您是否会考虑基于以下方法模式 - 但它有效，并且可以想象它可以扩展到许多维度，尽管使用all3数据集，它可能会很早就结束......

这个想法是从一个空白的填字游戏开始：

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

然后递归地执行以下操作：对于给定的模式，依次查看行并（在填写完任何一个后）在匹配数最少的行上展开模式： 

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

我首先进行递归广度以便能够使用 Union，但对于更大的问题可能需要深度优先。性能一般：在示例问题中找到 116568 个匹配项需要 8 分钟的笔记本电脑时间：

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+ 大小的词表...

于 2011-02-03T02:28:22.817 回答
8

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

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


（来源：yaroslavvb.com）

这种方法使用变量{{i,j},"c"}来表示单元格{i,j}获取字母“c”。每个单元格都被限制得到一个带有 的字母BooleanCountingFunction，每一行和每一列都被限制为一个有效的单词。例如，第一行必须是“ace”或“bar”的约束看起来像这样

{{1,1},"a"}&&{{1,2},"c"}&&{{1,3},"e"}||{{1,1},"b"}&&{{1,2},"a"}&&{{1,3},"r"}
于 2011-02-01T22:41:44.873 回答