The December 12, 2021 New York Times Magazine puzzle section introduced a new type of word search puzzle, called Sit for a spell. It consists of an undirected graph of 13 vertices labelled by English letters connected as shown:
(The generating code is below.)
The task is to start at any node you like, then traverse the graph to pass through additional nodes to form a chain of a total of six or more nodes (which can be duplicated) so as to spell out a valid English word. Crucial is that at least one of the letters must be doubled, e.g., "oo", "nn", and so on. Thus some valid solutions this week are:
- sonnet
- hobble
- blooms
- blossom
and so on.
I'm looking for efficient code, which will surely use DictionaryLookup, to find all valid solutions. (For the puzzle shown, there should be at least 42 such valid words.)
Choosing each node in turn and searching all possible paths starting from each seems inefficient.
I'm having difficulty efficiently searching all such paths and ensuring the "at least one double letter" constraint.
Here's some useful syntax:
StringJoin /@ FindPath[sitForASpell, "o", "e", {6}, All]
which finds all paths between "o" and "e" of exactly length 6 and makes strings of them (suitable for DictionaryLookup).
Alas, I don't immediately know how to ensure that double letters appear in such paths. FindPath finds only simple paths (no loops).
After all, this code finds a valid word of length 5 but without the required letter duplication:
DeleteCases[
DictionaryLookup[#] & /@
StringJoin /@ FindPath[sitForASpell, "c", "s", {5}, All], {}]
Suggestions?
Bonus: Since this puzzle will appear weekly for quite a while, I'd like the simplest puzzle entry method, specifically just enter the vertex letters in a specified order. Presumably this graph can be constructed and laid out with cleverness using CircleNumbers and such.
Code for graph:
sitForASpell = Graph[Characters["hmscpboidtnle"],
{"h" \[UndirectedEdge] "h", "m" \[UndirectedEdge] "m",
"s" \[UndirectedEdge] "s", "c" \[UndirectedEdge] "c",
"p" \[UndirectedEdge] "p", "b" \[UndirectedEdge] "b",
"o" \[UndirectedEdge] "o", "i" \[UndirectedEdge] "i",
"d" \[UndirectedEdge] "d", "t" \[UndirectedEdge] "t",
"n" \[UndirectedEdge] "n", "l" \[UndirectedEdge] "l",
"e" \[UndirectedEdge] "e",
"h" \[UndirectedEdge] "m", "h" \[UndirectedEdge] "s",
"h" \[UndirectedEdge] "o", "h" \[UndirectedEdge] "c",
"h" \[UndirectedEdge] "b",
"m" \[UndirectedEdge] "s", "m" \[UndirectedEdge] "p",
"m" \[UndirectedEdge] "o", "m" \[UndirectedEdge] "i",
"s" \[UndirectedEdge] "c", "s" \[UndirectedEdge] "p",
"s" \[UndirectedEdge] "o",
"c" \[UndirectedEdge] "b", "c" \[UndirectedEdge] "o",
"c" \[UndirectedEdge] "d", "p" \[UndirectedEdge] "o",
"p" \[UndirectedEdge] "i", "p" \[UndirectedEdge] "t",
"b" \[UndirectedEdge] "o", "b" \[UndirectedEdge] "d",
"b" \[UndirectedEdge] "l",
"o" \[UndirectedEdge] "i", "o" \[UndirectedEdge] "d",
"o" \[UndirectedEdge] "t", "o" \[UndirectedEdge] "n",
"o" \[UndirectedEdge] "l", "o" \[UndirectedEdge] "e",
"i" \[UndirectedEdge] "t", "i" \[UndirectedEdge] "e",
"d" \[UndirectedEdge] "n", "d" \[UndirectedEdge] "l",
"t" \[UndirectedEdge] "n", "t" \[UndirectedEdge] "e",
"n" \[UndirectedEdge] "l", "n" \[UndirectedEdge] "e",
"l" \[UndirectedEdge] "e"},
VertexSize -> .5,
VertexLabels -> Placed["Name", Center],
VertexLabelStyle -> 24,
VertexCoordinates -> {
2 {Cos[2 \[Pi]/3], Sin[2 \[Pi]/3]},
2 {Cos[\[Pi]/3], Sin[\[Pi]/3]},
{Cos[\[Pi]/2], Sin[\[Pi]/2]},
{Cos[5 \[Pi]/6], Sin[5 \[Pi]/6]},
{Cos[\[Pi]/6], Sin[\[Pi]/6]},
2 {-1, 0},
{0, 0},
2 {1, 0},
{Cos[7 \[Pi]/6], Sin[7 \[Pi]/6]},
{Cos[11 \[Pi]/6], Sin[11 \[Pi]/6]},
{0, -1},
2 {Cos[4 \[Pi]/3], Sin[4 \[Pi]/3]},
2 {Cos[5 \[Pi]/3], Sin[5 \[Pi]/3]}}]
characters = Characters[string];candidates = Select[StringLength@# >= 6 &]@ Flatten@(DictionaryLookup[(Alternatives @@ DeleteCases[characters, #] ...) ~~ # ~~ # ~~ (Alternatives @@ DeleteCases[characters, #] ...)] & /@ characters)and picking the ones that (after removing duplicate letters) correspond to some path in the graph without self-loops.? $\endgroup$