# "Sit for a spell" graph search

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]}}]

• Typo. Fixed. Thanks. Commented Dec 13, 2021 at 6:21
• Perhaps you can tweak the loops? E.g. have node "e" connect to "i" through a direct link and through a new link "E". Then you can have the path eEi and ei?
– Lou
Commented Dec 13, 2021 at 6:49
• perhaps we can go in the opposite direction from dictionary words to paths. Finding candidate words 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.?
– kglr
Commented Dec 13, 2021 at 7:12

As @kglr suggested in the comments, it's better to go the opposite way, find all the words, and match them to the pattern.

Store all the associations in a list:

data = {"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"};


Now we create an Association to give us the available nodes by giving a character. Since they're undirected, also join the reverse:

chars = GroupBy[Join[data, Reverse /@ data], First -> Last]

(* Out: <|"h" -> {"h", "m", "s", "o", "c", "b", "h"},
"m" -> {"m", "s", "p", "o", "i", "m", "h"},
"s" -> {"s", "c", "p", "o", "s", "h", "m"},
"c" -> {"c", "b", "o", "d", "c", "h", "s"},
"p" -> {"p", "o", "i", "t", "p", "m", "s"},
"b" -> {"b", "o", "d", "l", "b", "h", "c"},
"o" -> {"o", "i", "d", "t", "n", "l", "e", "o", "h", "m", "s", "c", "p", "b"},
"i" -> {"i", "t", "e", "i", "m", "p", "o"},
"d" -> {"d", "n", "l", "d", "c", "b", "o"},
"t" -> {"t", "n", "e", "t", "p", "o", "i"},
"n" -> {"n", "l", "e", "n", "o", "d", "t"},
"l" -> {"l", "e", "l", "b", "o", "d", "n"},
"e" -> {"e", "e", "o", "i", "t", "n", "l"}|> *)


Create a function to test whether the given string is matched by the pattern (graph):

ClearAll[test];

test[text_] :=
And @@ (Unevaluated[MemberQ[chars[#1], #2]] & @@@
Partition[Characters[text], 2, 1])


Use DictionaryLookup to list all the words starting with the nodes (keys) and have a duplicated word in them and select those that pass the test.

result=Select[DictionaryLookup[
Alternatives @@ Keys@chars ~~ ___ ~~
Repeated[x_, {2, Infinity}] ~~ ___, IgnoreCase -> True], test]


You'll get 131 words in around 0.3 seconds on my computer (Ryzen 1700):

{"blood", "bloom", "blooms", "bloop", "bloops", "blossom",
"blossoms", "blotto", "bobble", "boll", "bonnet", "boo", "boob",
"boodle", "boohoo", "boohoos", "boom", "booms", "boon", "boos",
"boot", "bootee", "boss", "bottom", "bottoms", "cobble", "cocoon",
"coddle", "colleen", "commie", "commit", "committee", "common",
"commotion", "connote", "coo", "cool", "coon", "coop", "coops",
"coos", "coot", "cootie", "cotton", "doddle", "doll", "dollop",
"dollops", "doodle", "doom", "dooms", "doss", "ell", "ennoble",
"hobble", "hooch", "hood", "hoodoo", "hoodoos", "hoop", "hoops",
"hoot", "lee", "loll", "lollop", "lollops", "loo", "loom", "looms",
"loon", "loop", "loops", "loos", "loot", "loss", "lotto", "mitt",
"mitten", "moll", "moo", "mooch", "mood", "moon", "moos", "moot",
"moss", "motto", "nee", "nett", "nobble", "noddle", "noodle", "noon",
"odd", "opponent", "poll", "pollen", "pontoon", "pooch", "poodle",
"pooh", "poohs", "pool", "poop", "poops", "school", "scoop",
"scoops", "scoot", "shh", "shoo", "shoos", "shoot", "smitten",
"smooch", "sonnet", "soon", "soot", "spittoon", "spool", "spoon",
"tee", "teen", "tell", "toddle", "toll", "tonne", "too", "tool",
"toot", "toss"}


Note that we hadn't filtered by length:

Select[result, StringLength[#] >= 6 &]


if we do that, 50 words remain:

{"blooms", "bloops", "blossom", "blossoms", "blotto", "bobble",
"bonnet", "boodle", "boohoo", "boohoos", "bootee", "bottom",
"bottoms", "cobble", "cocoon", "coddle", "colleen", "commie",
"commit", "committee", "common", "commotion", "connote", "cootie",
"cotton", "doddle", "dollop", "dollops", "doodle", "ennoble",
"hobble", "hoodoo", "hoodoos", "lollop", "lollops", "mitten",
"nobble", "noddle", "noodle", "opponent", "pollen", "pontoon",
"poodle", "school", "scoops", "smitten", "smooch", "sonnet",
"spittoon", "toddle"}


After re-implementing the algorithm in Julia, I notice we missed 3-character words that the first character repeated (because of the way we search in DictionaryLookup), for a comprehensive result, add these to the list:

{"eel", "ooh", "oohs", "oops", "ppm", "ssh"}

• Superb. Just superb. Thanks so much, and a hearty ($+1$) and ($\checkmark$). Once again, @kglr points the way! Commented Dec 13, 2021 at 18:06
• I think @kglr should be invited on Lex Fridman's podcast.
– Lou
Commented Dec 13, 2021 at 18:30
• @Lou: I've thanked the anonymous kglr in my forthcoming book from Wiley. I doubt kglr would go on to Fridman's podcast because he'd have to shed his anonymity... but it is worth asking! (Incidentally, I've been scheduled for Lex Fridman's podcast to talk about AI and art history... but have been postponed to post-COVID times.) Commented Dec 13, 2021 at 18:42
• @DavidG.Stork That would be great if you would show up in a Lex podcast!
– Lou
Commented Dec 14, 2021 at 8:41

### Graph:

Take a 13-character string as input and construct a graph where letters are placed in a spiral layout starting with the first letter at the center:

ClearAll[sitForASpellGraph]

sitForASpellGraph[lbls_String: Automatic, opts : OptionsPattern[]] :=
Module[{ord = Prepend[1] @ Riffle[#, 6 + #] & @ Range[2, 7],
adjm = PadLeft[ToeplitzMatrix[{1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1}], {13, 13}, 1]},
AdjacencyGraph[lbls /. {Automatic -> ord, s_String :> Characters[s][[ord]]},
adjm, opts, VertexSize -> Large, VertexLabels -> Placed["Name", Center],
VertexCoordinates -> Join[{{0, 0}},
Riffle[CirclePoints[{1, Pi/6}, 6], RotateLeft[2 CirclePoints[6], 2]]]]]


Examples:

string = "opscdntmhblei";

Row[{sitForASpellGraph[ImageSize -> Medium],
sitForASpellGraph[string, ImageSize -> Medium, VertexLabelStyle -> 18,
VertexStyle -> Thread[Characters[string] -> (ColorData[97] /@ Range[13])]]},
Spacer[10]]


### Words:

ClearAll[sitForASpellWords]

sitForASpellWords[str_] := Module[{allwords, pairs, sel,
alt = Alternatives @@ Characters @ str,
edges = List @@@ EdgeList @ sitForASpellGraph @ str},
pairs = Union[#, Reverse /@ #] &[edges];
allwords = DictionaryLookup[alt ...]; (*words formed by letters of str *)
sel = StringMatchQ[#, ___ ~~ $$a_ ~~$$a_ ~~ ___] (* has double letters *)
&& StringLength @ # >= 6 (* six characters or longer *)
&& SubsetQ[pairs, Partition[Characters @ #, 2, 1]] &;
(* consecutive letters are connected in sitForASpellGraph[str] *)
Select[sel] @ allwords]


Examples:

sitForASpellWords[string] // RepeatedTiming

{0.070,
{"blooms", "bloops", "blossom", "blossoms", "blotto", "bobble",
"bonnet", "boodle", "boohoo", "boohoos", "bootee", "bottom",
"bottoms", "cobble", "cocoon", "coddle", "colleen", "commie",
"commit", "committee", "common", "commotion", "connote", "cootie",
"cotton", "doddle", "dollop", "dollops", "doodle", "ennoble",
"hobble", "hoodoo", "hoodoos", "lollop", "lollops", "mitten",
"nobble", "noddle", "noodle", "opponent", "pollen", "pontoon",
"poodle", "school", "scoops", "smitten", "smooch", "sonnet",
"spittoon", "toddle"}}

SeedRandom[1]
string2 = StringJoin@ RandomSample @ Characters@string

"pdomlhsbnitce"

sitForASpellWords[string2] // RepeatedTiming

{0.080,
{"bedded", "beeped", "beseech", "bobbed", "boobed", "bopped",
"cesspit", "deeded", "dobbed", "lipped", "millipede", "millipedes",
"mobbed", "mopped", "nipped", "nodded", "oopses", "peepbo",
"peeped", "pepped", "pipped", "pippin", "podded", "pooped",
"popped", "seedbed", "seedbeds", "seeded", "seedpod", "seedpods",
"seeped", "speech", "speeds", "tipped"}}

SeedRandom[7]
wowels = {"a", "e", "i", "o", "u"};
consonants = Complement[Alphabet[], wowels];

strng = StringJoin @ RandomSample @
Join[RandomSample[consonants, 10], RandomSample[wowels, 3]]


"dkzgemovrnuwy"

Row[{sitForASpellGraph[strng, ImageSize -> Medium,
VertexLabelStyle -> 18,
VertexStyle -> Thread[Characters[strng] -> (ColorData[97] /@ Range[13])]],
Column[sitForASpellWords[strng]]}]


This is a simple, brute-force random search that does not consider letter doubling. I am posting it because it's a one-liner and it does find some solutions.

Needs["IGraphM"]

Union@Table[
DictionaryLookup@StringJoin@IGRandomWalk[g, RandomChoice@VertexList[g], 5],
10000
] // Timing

{1.92729,
{{}, {"blend"}, {"blocs"}, {"blond"}, {"bloom"}, {"coops"}, {"dodos"},
{"hobos"}, {"pipit"}, {"schmo"}, {"tenon"}}}
`