Кроссворды в Mathematica с использованием сопоставления шаблонов

Предположим, что я выбрал все слова 3 char из словаря Mathematica:

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

и я хочу создать полные скребущие наборы, например:

A B E
R A Y
E R E

Где слова могут быть прочитаны горизонтально и вертикально.

Ясно, что множества можно найти с рекурсией и возвратом. Но:

1) Есть ли способ решить это с помощью шаблонов?
2) Для каких размеров существуют правильные решения?

Изменить

Я написал вопрос для DictionaryLookup[] только потому, что это база данных разумного размера записей переменной длины. Моя реальная проблема не связана с поиском словаря, а с определенными типами строчек.

Ответ 1

Я не уверен, рассмотрим ли вы следующий шаблон подхода, но он работает, и его можно, возможно, расширить до многих измерений, хотя с набором данных all3 он, скорее всего, возникнет довольно рано...

Идея состоит в том, чтобы начать с чистого кроссворда:

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

а затем рекурсивно выполните следующее: для данного шаблона просмотрите строки по очереди и (после заполнения любого из них с одним завершением) разверните шаблон в строке с наименьшим количеством совпадений:

(* Cache the number of matches for a given pattern *)
nmatch[patt_]:=nmatch[[email protected]][email protected][all3,patt]

(* A helper to fill single matches if needed *)
fixone[ml_,nl_]:=If[FreeQ[ml[[nl]],Verbatim[_]],ml, 
  ReplacePart[ml, nl->[email protected][all3,ml[[nl]]]]];

findCompletions[m_]:=Module[{nn,ur},
  (* Pattern w/ filled single matches -> ur, ordering by # of matches -> nn *)
  {ur,nn}=NestWhile[{fixone[#[[1]],[email protected]#[[2]]], [email protected]#[[2]]}&,
    {m,Ordering[nmatch/@m]},
    (Length[#[[2]]]>0&&[email protected]#[[1,#[[2,1]]]]==1)&];

  (* Expand on the word with the fewest number og matches *)
  If[Length[nn]==0,{ur},
    With[{[email protected]},ReplacePart[ur,n-> #]&/@Cases[all3,ur[[n]]]]]];

Для выбранного шаблона кандидата попробуйте выполнить по обоим измерениям и сохраните тот, который дает наименьшее количество:

findCompletionsOriented[m_]:=Module[{osc},
  osc=findCompletions/@Union[{m,[email protected]}];
  osc[[[email protected][Length/@osc,1]]]]

Сначала я использую ширину рекурсии, чтобы иметь возможность использовать Union, но сначала может потребоваться глубина для больших проблем. Производительность так себе: 8 минут ноутбука, чтобы найти совпадения 116568 в примере проблемы:

Timing[crosswords=FixedPoint[Union[[email protected]@(findCompletionsOriented/@#)]&,{blankCW}];]
[email protected]
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. Если время сопоставления шаблона с списком является линейным по длине списка, это будет быть довольно медленным со списком слов размером 100 000+...

Ответ 2

Альтернативный подход заключается в использовании SatisfiabilityInstances с ограничениями, указывающими, что каждая строка и каждый столбец должны быть допустимым словом. Код ниже занимает 40 секунд, чтобы получить первые 5 решений, используя словарь из 200 трехбуквенных слов. Вы можете заменить SatisfiabilityInstances на SatisfiabilityCount, чтобы получить количество таких кроссвордов.

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

   words = Characters /@ wordStrings;
   chars = [email protected]@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];
[email protected]@[email protected]# & /@ vals

_{(источник: yaroslavvb.com)}

Этот подход использует переменные, такие как {{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"}