8
$\begingroup$

The Sunday New York Times magazine has a puzzle, CRAZY EIGHTS such as this:

enter image description here

The goal is to fill in the $4 \times 4$ unfilled squares with letters to make valid 8-letter words reading both horizontally and vertically.

The horizontal words in the solution are:

CONCEALS, UNEARNED, PHYSIQUE, HABITUAL

and the vertical words in the solution are:

HONEYBEE, OCCASION, APEARITIF, TRANQUIL

The way to get candidate words for a single line are shown in this example:

 `DictionaryLookup["ho"<>_<>_<>_<>_<>"ls"]`

How to code the full solution to the puzzle?

$\endgroup$
3
  • 1
    $\begingroup$ In your example code, did you mean something like DictionaryLookup["ho" ~~ Repeated[_, 4] ~~ "ee"]? $\endgroup$
    – MarcoB
    Jul 5 at 2:40
  • 1
    $\begingroup$ I think the third vertical solution should be "aperitif" which is 8 characters and the third column end with "if" instead of "in". $\endgroup$
    – Ben Izd
    Jul 5 at 3:59
  • $\begingroup$ @MarcoB: There are a number of ways to code that portion, including DictionaryLookup["ho"~~___~~"ee" && Length[#] == 8&] $\endgroup$ Jul 5 at 5:31

2 Answers 2

13
$\begingroup$

First, we'll search all the choices for the given row/column, then we check their StringTake[ ... , {3,-3}] with transpose and return the first item it finds.

I hardcoded the loops (since the structure probably won't change).

ClearAll[solveCrazyEight];

solveCrazyEight[horizontalWords_,verticalWords_]:=Block[{h1Choices,h2Choices,h3Choices,h4Choices,v1Choices,v2Choices,v3Choices,v4Choices},

{h1Choices,h2Choices,h3Choices,h4Choices,v1Choices,v2Choices,v3Choices,v4Choices}=
DictionaryLookup[StringExpression@@Riffle[#,Repeated[_,{4}]],IgnoreCase->True]&/@Catenate@Outer[StringTake,{horizontalWords,verticalWords},{2,-2}];

Do[If[StringTake[{v1,v2,v3,v4},{3,-3}]==(StringJoin/@Transpose@Characters[StringTake[{h1,h2,h3,h4},{3,-3}]]),Return[{h1,h2,h3,h4,v1,v2,v3,v4}]]
,{h1,h1Choices},{h2,h2Choices},{h3,h3Choices},{h4,h4Choices},{v1,v1Choices},{v2,v2Choices},{v3,v3Choices},{v4,v4Choices}]//AbsoluteTiming
]

Example:

The first timing is for the whole operation, second is for finding the right combination:

solveCrazyEight[{"cols", "uned", "phue", "haal"}, {"hoee", "ocon", "apif", "tril"}] // AbsoluteTiming

(* Out: {0.121019, {0.0132017, {"conceals", "unearned", "physique", "habitual",
                                "honeybee", "occasion", "aperitif", "tranquil" }}} *)

As for the other puzzle, it takes a little more time:

solveCrazyEight[{"leds", "mani", "ints", "vice"}, {"knff", "poes", "stts", "maed"}] // AbsoluteTiming

(* Out: {0.438258, {0.32986, {"leotards", "macaroni", "inkblots", "violence", 
                              "knockoff", "potables", "starlets", "marooned" }}} *)
$\endgroup$
1
  • $\begingroup$ Yep... works like a charm, as tested on: solveCrazyEight[{"leds", "mani", "ints", "vice"}, {"knff", "poes", "stts", "maed"}] ($+1, \checkmark$) $\endgroup$ Jul 5 at 5:34
13
$\begingroup$

enter image description here

A 2D array of string patterns

Here I define a function that creates a SparseArray with string patterns defining the constraints available

createpattern[l1_,l2_]:= SparseArray[
{
{1|2|7|8,1|2|7|8}->"",
Splice@Flatten[Thread/@Thread[Outer[List,{3,4,5,6},{1,2,7,8}]->Characters[l1]]],
Splice@Flatten[Thread/@Thread[Outer[Reverse@*List,{3,4,5,6},{1,2,7,8}]->Characters[ l2]]]
}
,{8,8}
,_]

Now we set the problem copying the format proposed by @BenIzd

pattern=createpattern[
   {"cols", "uned", "phue", "haal"},
   {"hoee", "ocon", "apif", "tril"}
];

enter image description here

Now I define some auxiliary functions to solve the problem

updatepattern[pat_]:= ReplaceAll[#,{{a_}:>a,List:>Alternatives}]&/@
Union/@Transpose@Map[
   Characters,
   ToLowerCase@DictionaryLookup[Apply[StringExpression,Normal@pat],IgnoreCase->True]
]
updaterow[n_]:=(pattern[[n]]=updatepattern[pattern[[n]]];)
updatecol[n_]:=(pattern[[All,n]]=updatepattern[pattern[[All,n]]];)

To solve, the pattern defined by columns or rows is given as an argument to DictionaryLookup and a new pattern is defined based on the possible word matching.

For example, on row 6, with an original pattern {"h","a",_,_,_,_,"a","l"} only the words "habitual" and "Hannibal" are possible, so the new pattern for that row is now {"h","a","b"|"n","i"|"n","i"|"t","b"|"u","a","l"}

enter image description here

This way each new DictionaryLookup takes advantage of what was learned on previous searches. Now we only need to apply the update to all columns and rows.

AbsoluteTiming[  
   Table[
     updaterow[k];
     updatecol[k];
     ,{k,{3,4,5,6}}
   ];
MatrixForm@Normal[pattern]
]

enter image description here

This implies 8 update iterations, which is redundant. A solution is possible with fewer iterations, see the animated GIF for a 6-step solution where each step has a unique word.

enter image description here

The other problem

MatrixForm[
pattern=createpattern[
{"leds", "mani", "ints", "vice"},
{"knff", "poes", "stts", "maed"}
];
]

enter image description here

Further problems

It would be nice to find the optimum path for somebody to solve by hand, like in the animation at the beginning of the answer, in which each step has a unique answer.

$\endgroup$
1
  • 2
    $\begingroup$ Oh... very nice addition, especially the display (a hearty $+1$). $\endgroup$ Jul 5 at 15:46

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.