Кроссворды в Mathematica с использованием Pattern Matching - PullRequest
Новая
       22

Кроссворды в Mathematica с использованием Pattern Matching

12 голосов
/ 01 февраля 2011

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

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

и хочу сформировать полные наборы, похожие на скрэббл, например: 

A B E
R A Y
E R E

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

Очевидно, что наборы можно найти с помощью рекурсии и возврата.Но:

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

Редактировать

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

Ответы [ 2 ]

11 голосов
/ 03 февраля 2011

Я не уверен, если вы рассмотрите следующий шаблон подхода, основанный - но он работает, и его можно расширить на многие измерения, хотя с набором данных 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+ размерным списком слов ...

8 голосов
/ 02 февраля 2011

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

http://yaroslavvb.com/upload/save/crosswords.png

Этот подход использует переменные типа {{i,j},"c"} для обозначения ячейки {i,j} получает букву "с".Каждая ячейка ограничена, получают ровно одну букву с BooleanCountingFunction, каждая строка и столбец ограничены, чтобы составить правильное слово.Например, ограничение, что первая строка должна быть либо «туз», либо «бар» выглядит следующим образом 

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