In addition to their crosswords, The New York Times has also been publishing other word games, including one called Letter Boxed. Basically, you write words using only letters that appear on the box, and such that letters from the same side do not appear consecutively. Letters can be used more than once (though not consecutively because then there would be two consecutive letters from the same side). Here is a screenshot of the rules:
It occurred to me that these should be easily solvable by a computer. Here is the code:
This variable stores the letters which appear on each side:
sides=Characters/@{"dti","gmw","aeu","jns"}
Out[]=
{{d,t,i},{g,m,w},{a,e,u},{j,n,s}}
This association maps letters to side indices:
In[]:=
letterSides=Merge[MapIndexed[#1#2[[1]]&,sides,{2}],Identity];
Prune by selecting words that only use letters that appear on the box:
In[]:=
words=Select[Union[ToLowerCase[WordList["KnownWords"]]],ContainsOnly[Characters[#],Catenate[sides]]&];
Prune further by selecting those which use letters from alternating sides:
In[]:=
words2=Select[words,Function[w,Catch[Fold[With[{newSides=Complement[letterSides[#2],#1]},If[newSides==={},Throw[False],newSides]]&,{},Characters[w]];True]]];
Get the association mapping first letters to words:
In[]:=
letterWords=GroupBy[words2,StringPart[#,1]&];
Find minimal solutions by brute force:
In[]:=
solutionQ[words_,sides_]:=ContainsAll[Catenate[Characters/@words],Catenate[sides]]solutionQ[sides_][words_]:=solutionQ[words,sides]
SortBy[Select[NestWhile[DeleteDuplicates@*Catenate@*Map[Function[s,Append[s,#]&/@Complement[letterWords[StringPart[s[[-1]],-1]],s]]],List/@words2,FreeQ[_?(solutionQ[sides])]],solutionQ[sides]],Total@*StringLength]
Out[]=
{{adjustment,twig},{jawed,designatum},{adjustment,twinge},{ndjamena,atsugewi},{judgement,taiwanese}}
Putting it all together, this function solves Letter Boxed:
In[]:=
solveLetterBoxed[sides_]:=Module[{letterSides,words,words2,letterWords},letterSides=Merge[MapIndexed[#1#2[[1]]&,sides,{2}],Identity];words=Select[Union[ToLowerCase[WordList["KnownWords"]]],ContainsOnly[Characters[#],Catenate[sides]]&];words2=Select[words,Function[w,Catch[Fold[With[{newSides=Complement[letterSides[#2],#1]},If[newSides==={},Throw[False],newSides]]&,{},Characters[w]];True]]];letterWords=GroupBy[words2,StringPart[#,1]&];SortBy[Select[NestWhile[DeleteDuplicates@*Catenate@*Map[Function[s,Append[s,#]&/@Complement[letterWords[StringPart[s[[-1]],-1]],s]]],List/@words2,FreeQ[_?(solutionQ[sides])]],solutionQ[sides]],Total@*StringLength]]
And we can run it to solve today's puzzle:
solveLetterBoxed[Characters/@{"dti","gmw","aeu","jns"}]
Out[]=
{{adjustment,twig},{jawed,designatum},{adjustment,twinge},{ndjamena,atsugewi},{judgement,taiwanese}}
This algorithm is not very efficient, and it could take a while to generate solutions in some cases (especially ones where the minimum solution is 3 or 4 words long.) Fortunately those do not appear to be very common.
AbsoluteTiming[solveLetterBoxed[Characters/@{"dti","gmw","aeu","jns"}]]
Out[]=
{2.33717,{{adjustment,twig},{jawed,designatum},{adjustment,twinge},{ndjamena,atsugewi},{judgement,taiwanese}}}
Some other examples:
AbsoluteTiming[Short@solveLetterBoxed[Characters/@{"tjo","feb","hil","cuy"}]]
Out[]=
{1.38323,{{objectify,youthful}}}
AbsoluteTiming[Short@solveLetterBoxed[Characters/@{"mlr","snp","gyo","uat"}]]
Out[]=
{2.74201,{{plug,gastronomy},{grampus,strongly},24,{unglamourous,synaptomys}}}
AbsoluteTiming[Short@solveLetterBoxed[Characters/@{"ncx","itp","era","hlo"}]]
Out[]=
{3.14821,{{troche,explain},{chronicle,expat},229,{anthropocentric,cephalexin}}}
I also tried to use linear programming to solve this more efficiently, but I found that the matrices quickly became far too big.