Mathematica 中使用模式匹配的填字游戏

发布于 2024-10-15 05:51:53 字数 440 浏览 2 评论 0原文

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

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

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

A B E
R A Y
E R E

可以水平和垂直阅读单词的位置。

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

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

编辑

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

原文

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.

分享到QQ

分享到微博

如果你对这篇内容有疑问，欢迎到本站社区发帖提问参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

发布评论

需要登录才能够评论，你可以免费注册一个本站的账号。

叹沉浮 2024-10-22 05:51:53

我不确定您是否会考虑以下基于模式的方法 - 但它有效，并且可以想象它可以扩展到许多维度，尽管使用 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，但对于更大的问题可能需要深度优先。性能一般：笔记本电脑需要 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+ 大小的单词列表来说，这会非常慢......

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...

回复收藏 0 原文

指尖凝香 2024-10-22 05:51:53

另一种方法是使用 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"}

An alternative approach is to use SatisfiabilityInstances with constraints specifying that every row and every column must be a valid word. Code below takes 40 seconds to get first 5 solutions using dictionary of 200 three-letter words. You could replace SatisfiabilityInstances with SatisfiabilityCount to get the number of such crosswords.

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

_{(source: yaroslavvb.com)}

This approach uses variables like {{i,j},"c"} to indicate the cell {i,j} gets letter "c". Each cell is constrained get exactly one letter with BooleanCountingFunction, every row and column is constrained to make a valid word. For instance, constraint that first row must be either "ace" or "bar" looks like this

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

回复收藏 0 原文

~没有更多了~

关于作者

心病无药医

暂无简介

0 文章

0 评论

22 人气

关注发私信

友情链接

文江博客

Mathematica 中使用模式匹配的填字游戏

如果你对这篇内容有疑问，欢迎到本站社区发帖提问参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

发布评论

评论（2）

关于作者

相关话题

热门标签

推荐作者

留蓝

18790681156

zach7772

Wini

ayeshaaroy

初雪

友情链接

Mathematica 中使用模式匹配的填字游戏

如果你对这篇内容有疑问，欢迎到本站社区发帖提问 参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

发布评论

评论（2）

关于作者

相关话题

热门标签

推荐作者

留蓝

18790681156

zach7772

Wini

ayeshaaroy

初雪

友情链接

如果你对这篇内容有疑问，欢迎到本站社区发帖提问参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。