字謎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"}