Finding all dictionary words that can be made with a given set of characters (Wordfeud/Scrabble)

Question

This is a slightly more involved variant of this recent question. By sheer coincidence I happened to have been building a Wordfeud (Scrabble clone) game in Mathematica.

My interactive Wordfeud board in Mathematica

I used DictionaryLookup with StringExpression to find matches corresponding to my hand (7 letters) and the fixed letters in the same row on the board that can be used. With 15 characters on a row that would be a maximum of 8 extra letters at fixed positions.

I believe Mr.wizard's solution of generating all permutations would be unbearably slow in this case. I wonder whether the mma.se community has better ideas for this variant.

Being far removed from my own MMA installation I can't currently post what I've got so far, but will do so this weekend. My solution typically took somewhere around 10-20 secs if memory serves, which is a tad slow.

The next step-up in complexity would be having to deal with all potential words crossing your row. Extra points if you have ideas to tackle that efficiently.

Answer 1

My attempt:

First we define the existing row, using dots to represent empty squares, and our hand of 7 letters.

row="...t.t...r..e..";
letters="aodalip";

Next define a function to count how many times each of our letters appears in a given string. Also run this function on our letters, to count how many of each we have.

lettercount[str_]:=StringCount[str,#]&/@Characters[letters];
mylettercounts=lettercount[letters];

Next consider where our new word could start and finish. It can't start immediately to the right of an existing letter, nor can it finish immediately to the left of an existing letter.

cantstarthere=StringPosition[row,Except["."]][[All,1]]+1;
startpoints=Complement[Range[14],cantstarthere];
cantendhere=cantstarthere-2;
endpoints=Complement[1+Range[14],cantendhere];

Now that we have the list of valid start and end points, construct a list of substrings of row that could become our new word. It is also handy to keep note of what the start point is for each one. An additional constraint is that our new word must include one of the existing letters, so we remove any substrings of row which are all dots.

subrows=Flatten[Table[{m,StringTake[row,{m,n}]},{m,startpoints},{n,Select[endpoints,#>m&]}],1];
subrows=Select[subrows,Not@StringMatchQ[#[[2]],"."..]&];

Now convert each substring of row into a regular expression, replacing each dot with ([any of our letters]).

starts=subrows[[All,1]];
regexes=StringReplace[subrows[[All,2]],"."->"(["<>letters<>"])"];

Next we search the dictionary for any words matching the regular expression. A slight wrinkle is that we might have used one of our letters twice, so we use the regular expression again in StringCases to pick out which letters were used to match the ([any of our letters]) templates. We use this information to weed out any words which we can't actually make.

results=Table[
reg=regexes[[j]];
possiblewords=DictionaryLookup[RegularExpression[reg]];
lettersused=Flatten[StringCases[#,RegularExpression[reg]->"$1$2$3$4$5$6$7"]&/@possiblewords];
okay=(Max[(lettercount[#]-mylettercounts)]<1)&/@lettersused;
{starts[[j]],Pick[possiblewords,okay]}
,{j,Length[regexes]}];

Finally do a bit of tidying up, and present the words we can make along with their start points.

Column[DeleteDuplicates[Flatten[#]]&/@SplitBy[Select[results,#[[2]]!={}&],First]/.{a_Integer,b__}:>Rule[a,{b}]]


1->{dolt,plot}
2->{apt,dot,lit,lot,oat,opt,pat,pit,pot}
3->{at,it}
4->{tat,tot,total}
6->{ta,ti,to,tad,tap,til,tip,top,tapir}
8->{air,oar,par,lard,lira,lord,para,parade,parole,paroled}
9->{or,pro,drape,pride,prole}
10->{rape,ride,rile,ripe,rode,role,rope,raped,riled,riped,roped}
12->{lea,led,lei,pea,deal,deli,lead,leap,peal}

Answer 2

Would this do the trick?

selectWords[chars_, min_, max_] := 
 Module[{charsset = Union[chars], charstally = Tally[chars], baselist,
    baselistchars, baselistpicks},
  baselist = 
   ToLowerCase[DictionaryLookup[x__ /; min <= StringLength[x] <= max]]];
  baselistchars = 
   Select[Characters /@ baselist, Complement[#, charsset] === {} &];
  baselistpicks = 
   Complement[Tally@#, charstally, 
    SameTest -> (#1[[1]] === #2[[1]] && #1[[2]] <= #2[[2]] &)] === {} & /@ (baselistchars);
  Pick[StringJoin /@ baselistchars, baselistpicks]
  ]

Given a list of 15 chars:

mychars = Join[Characters["micasat"], Characters["aueiofgh"]]

selectWords[mychars, 4, 9] // Length // AbsoluteTiming
(*
===> {1.241242, 683}
*)

EDIT: Using regular expressions seems to be faster:

charsToRegular[chars_] := 
 RegularExpression[
  StringJoin[
   "^", (# <> "{0," <> ToString[#2] <> "}") & @@@ Sort[Tally[chars]], 
   "$"]]

selectWordsRE[chars_, min_, max_] := 
 With[{re = charsToRegular[chars],
   allcases = 
    ToLowerCase[
     DictionaryLookup[x__ /; min <= StringLength[x] <= max]]}, 
  Pick[allcases, 
   StringMatchQ[StringJoin[Sort[Characters@#]] & /@ allcases, re]]
  ]

Testing it:

selectWordsRE[mychars, 4, 8] // Length // AbsoluteTiming
(*
===> {0.990980, 683}
*)

selectWordsRE[mychars, 4, 8] === selectWords[mychars, 4, 8]
(*
===> True
*)

EDIT2: Adding filter of board:

Given that the 8 characters have a fixed order, after applying selectWordsRE we can do something like this to filter only the characters that fix in the board:

fixedboard = "..a..e.io.f.ugh"

We define:

boardToRE2[board_, len_] := 
 RegularExpression[
  StringJoin@
   Riffle[With[{res = 
       Union[Table[
         StringTake[board, {i, i + len - 1}], {i, 
          StringLength[board] - len + 1}]]},
     If[StringMatchQ[res[[1]], "." ..], res[[;; 1]], res]], "|"]]

filterByBoard[board_, words_] :=
 Flatten[Table[
   With[{re = boardToRE2[board, StringLength[group[[1]]]]}, 
    Pick[group, StringMatchQ[group, re]]], {group, 
    GatherBy[words, StringLength]}]]

Then we can test it with the previous example:

candidates = selectWordsRE[mychars, 4, 8];

(filtered = filterByBoard[fixedboard, candidates]) // Length // AbsoluteTiming

(*
===> {0.001720, 181}
*)

Answer 3

I originally wrote this to help in guessing a word of known length from a bunch of letters, The word guessing game has 10 letters given so I tried to optimize this for speed. I reworked it here for scrabble:

string = "hkxefri";
words = DictionaryLookup[{Apply[Alternatives, 
      Characters[string]]} ..];
joined = StringJoin /@ 
   Permutations[StringSplit[string, ""], StringLength[string]];
Select[words, MemberQ[joined, #] &]

This doesn't deal with existing letters on the row.

this code is slower but I don't know why:

joined = StringJoin /@ Permutations[Characters[string], 7];
First /@ Select[DictionaryLookup /@ joined, # != {} &]

Answer 4

As promised I'll provide the basics of my own approach here.

I needed a string pattern test to test whether a given string consists of a set of letters that is a subset of a given set of letters. Such as subset test is not a standard feature of Mathematica as far as I know.

With a bit of effort one can use MMA lists as sets. It's good to note that the lists {1,2,3} and {3,2,1} are different, whereas seen as sets they are the same. Sorting in canonical is often needed. So, here's my subset test:

subSetQ[mySet_, testSet_] := Intersection[mySet, testSet] == Sort[testSet]

Using this, finding all words using my hand and a fixed letter "e" on the board can be done this way:

mySet = {"a", "o", "d", "a", "l", "i", "p"}
DictionaryLookup[
    x : ___ ~~ "e" ~~ y : ___ /; subSetQ[mySet, Join[Characters[x], Characters[y]]], 
    IgnoreCase -> True
]

The lengths of the stringth x and y will most often bounded. That can be incorporated in this way:

DictionaryLookup[
  x : ___ ~~ "e" ~~ y : ___ /; 
   subSetQ[mySet, Join[Characters[x], Characters[y]]] && 
   StringLength[x] <= 3 && StringLength[y] <= 3, 
  IgnoreCase -> True
] // AbsoluteTiming

(*
==> {4.5812620, {"aide", "ailed", "ale", "aloe", "ape", "aped", 
  "dale", "deal", "deli", "die", "doe", "dole", "dope", "Ed", "Eli", 
  "Elia", "idea", "ideal", "idle", "ilea", "lade", "lea", "lead", 
  "leap", "led", "lei", "lie", "lied", "lode", "lope", "loped", "ode",
   "oiled", "ole", "ope", "oped", "pale", "paled", "pea", "peal", 
  "pedal", "pie", "pied", "pile", "piled", "plea", "plead", "plied", 
  "pole", "poled"}}
*)