Cruciverba in Mathematica usando il Pattern Matching

Question

Supponiamo di selezionare tutti e 3 char parole da Mathematica dizionario:

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

e voglio modulo completo di scrabble-come imposta, come:

A B E
R A Y
E R E  

Dove le parole si possono leggere in orizzontale e in verticale.

Chiaramente, il set può essere trovato con la ricorsione e il backtracking.Ma:

1) c'È un modo per risolvere utilizzando i modelli?
2) Per le dimensioni ci sono soluzioni valide?

Modifica

Ho scritto la domanda per DictionaryLookup[] solo perché è di dimensioni ragionevoli database di record di lunghezza variabile.Il mio vero problema non è legato al Dizionario ricerche, ma per un certo tipo di telaio dei modelli.

Answer 1

Io non sono sicuro che se si considera l'approccio seguente schema di base -- ma funziona, e può quindi essere estesa a molte dimensioni, anche se con il all3 set di dati, sarebbe probabilmente konk piuttosto presto...

L'idea è di iniziare con un vuoto cruciverba:

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

e poi, in modo ricorsivo, effettuare le seguenti operazioni:Per un dato modello, guardare le righe e (dopo la compilazione di qualsiasi con esattamente un completamento) espandere il modello sulla riga con il minor numero di partite:

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

Per un determinato candidato motivo, provare il completamento lungo entrambe le dimensioni e mantenere il rendimento con il minor:

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

Faccio la ricorsione in largo prima di essere in grado di utilizzare Unione, ma la profondità di primo potrebbe essere necessario per problemi più grandi.Prestazioni così così:8 del computer portatile di minuti per trovare i 116568 partite il problema di esempio:

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 linea di principio, dovrebbe essere possibile recurse questo in dimensioni superiori, vale a direutilizzando il cruciverba lista invece di vocabolario di dimensione 3.Se il tempo per la ricerca di una corrispondenza con un elenco è lineare nell'elenco di lunghezza, questo sarebbe abbastanza lento e con una 100000+ dimensioni dizionario...

Answer 2

Un approccio alternativo è da usare SatisfiabilityInstances con vincoli che specificano che ogni riga e ogni colonna devono essere una parola valida. Il codice seguente richiede 40 secondi per ottenere le prime 5 soluzioni usando un dizionario di 200 parole a tre lettere. Potresti sostituire SatisfiabilityInstances insieme a SatisfiabilityCount Per ottenere il numero di tali parole crociate.

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

_{(fonte: yaroslavvb.com)}

Questo approccio utilizza variabili come {{i,j},"c"} Per indicare la cellula {i,j} ottiene la lettera "c". Ogni cella è vincolata, ottieni esattamente una lettera con BooleanCountingFunction, ogni riga e colonna è vincolata a fare una parola valida. Ad esempio, il vincolo che la prima riga deve essere "asso" o "bar" sembra questo

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