Krzyżówki w Mathematica wykorzystujące Pattern Matching

Question

Przypuśćmy zaznaczyć wszystkie 3 char słowa ze słownika Mathematica:

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

i chcę tworzyć pełne zestawy scrabble podobny, jak:

A B E 
R A Y 
E R E 

gdzie słowa można czytać poziomo i pionowo.

Oczywiście, zestawy można znaleźć przy rekursji i nawracaniu. Ale:

1) Czy istnieje sposób rozwiązania go za pomocą wzorów?
2) Dla jakich wymiarów istnieją prawidłowe rozwiązania?

Edit

napisałem pytanie do DictionaryLookup[] tylko dlatego, że jest to rozsądne wielkości baza zapisach o zróżnicowanej długości. Mój prawdziwy problem nie jest związany z wyszukiwaniem słownika, ale z pewnym rodzajem wzorów krosna.

Answer 1

Nie jestem pewien, czy byłoby rozważyć następujący wzór podejście oparte - ale to działa, a może conceivably zostać przedłużony do wielu wymiarach, chociaż z all3 zbioru danych, to prawdopodobnie KONK się dość wcześnie ...

Chodzi o to, aby rozpocząć z pustą krzyżówka:

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

a następnie rekursywnie wykonać następujące czynności: Dla danego wzoru spójrz na ro WS z kolei i (po wypełnieniu któregokolwiek z dokładnie jednym zakończeniu) rozwinąć wzór na wierszu z najmniejszą liczbę meczy:

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

Dla danego wzorca kandydującego, wypróbować zakończenie wzdłuż obu wymiarach i zachować jeden, że dają najmniejsza:

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

zrobić szerokość rekurencji pierwszy, aby móc korzystać z Unią, ale głębokość najpierw może być konieczne dla większych problemów.Wydajność jest więc tak: 8 laptopów minut znaleźć 116568 mecze w przykładzie problemu:

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 

W zasadzie powinno być możliwe do recurse to do wyższych wymiarów, czyli z użyciem listy krzyżówki zamiast liście słów do Wymiar 3. Jeśli czas dopasowania wzoru do listy jest liniowy na liście, byłby dość powolny w przypadku listy słów o wielkości 100 000+ ...

Answer 2

Alternatywnym podejściem jest użycie SatisfiabilityInstances z ograniczeniami określającymi, że każdy wiersz i każda kolumna musi być poprawnym słowem. Poniższy kod zajmuje 40 sekund, aby uzyskać pierwsze 5 rozwiązań przy użyciu słownika 200 słów trzyliterowych. Możesz zamienić SatisfiabilityInstances na SatisfiabilityCount, aby uzyskać liczbę takich krzyżówek.

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

Podejście to wykorzystuje zmienne jak {{i,j},"c"} wskazać komórkę {i,j} dostaje litery "C". Każda komórka jest ograniczona uzyskać dokładnie jedną literę z BooleanCountingFunction, każdy wiersz i kolumna jest ograniczona, aby utworzyć poprawne słowo. Na przykład, ograniczenie, że pierwszy wiersz musi być albo „Ace” lub „bar” wygląda to

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