How to find a longest word path in dictionary?

Question

Cross post here

---

A word path means the last character of the last word is same to the first character of the next word.And the path have no duplicated word.If I have $55$ words,I can find it with this method.

Build a graph

SeedRandom[2]
string = Select[ToLowerCase[RandomSample[DictionaryLookup[]]], 
   3 < StringLength[#] < 5 &];
g = RelationGraph[StringTake[#, -1] == StringTake[#2, 1] &, 
  string[[;; 55]], VertexLabels -> "Name"]

Find a longest word path by Jason's answer here

allPaths = 
  FindPath[g, #2, #1, Infinity, All] & @@@ 
    Subsets[VertexList[g], {2}] // Apply[Join];
First[TakeLargestBy[allPaths, Length@Union@# &, 1]]

{calm,muir,reef,fray,yaws,seed,deaf,fnma,axis,stow,waft,tint,trig,good,duns,sill,loge,etch,hill,lath,howl}

Well I have to say this is a very very slow solution.I even cannot find more than $60$ words.Actually I want to find Length[DictionaryLookup[]]=92518 words. It seem I still have a long way to go.Do any suggestion can give?

Answer 1

This is really a comment and suggestion, but too long to put in a comment format (so please don't down-vote this).

---

I would speed the search by grouping words into the $26 \cdot 26$ classes that have the same first and last letters, i.e., $a..a$, $a..b$, $a..c$, $a..z$, $b..a$, $b..b$, $b..d$, etc. $z..z$.

Then notice the 26 groups that begin and end with the same letter, e.g.,

$\{ "alba", "arena", ... \}$, $\{ "barb", "bib", ...\}$, etc. If any words in these sets appear in the longest chain, then all do, linked together like a chain, and their order is irrelevant. Thus eliminate all but one word in each set, which remains as a "representative" word. Later, you can insert the full chain for the set for the representative in your final search results.

Consider the remaining classes, e.g., words beginning with "c" and ending with "t" (e.g., $\{ "cat", "cot", carrot", ...\}$. Naive search tries to find a path through each word, but they are all functionally equivalent. Thus force the search to use the words in a given order (e.g., alphabetical). That will cut down your search by several orders of magnitude in time.

A large part of the computational problem is searching paths through "equivalent" words, i.e., those having the same first and last letters, such as "cat" and "cut". The best approach, then, is to employ a dual representation: create a multi-graph with just 26 nodes, "a", "b", ... "z", representing the linking of words. Then each word is now represented by a link or edge, so "cat" would be a directed edge between the $c$ vertex and $a$ vertex. Now in this much smaller directed multi-graph, you search for the longest path. Once you have it you can insert whichever of the "equivalent" words you like in the links in that longest path. This represents a combinatorial speedup.

A teeny speedup: I would also ensure the graph has no self loops (words linking to themselves) before searching.

Answer 2

Still slow, but you can get some speeding up by eliminating some path findings:

SeedRandom[2]
string = Select[ToLowerCase[RandomSample[DictionaryLookup[]]], 
   3 < StringLength[#] < 5 &];
g = RelationGraph[StringTake[#, -1] == StringTake[#2, 1] &, 
   string[[;; 57]], VertexLabels -> "Name"];

(clength = Max[DeleteCases[Flatten[GraphDistanceMatrix[g]], Infinity]];
  (
     spath = FindShortestPath[g, #2, #1];
     slength = Length[spath];
     If[slength > 0,
      clength = Max[clength, slength];
      paths = FindPath[g, #2, #1, {clength, Infinity}, All]; 
      If[Length[paths] > 0, 
       path = First[TakeLargestBy[paths, Length@Union@# &, 1]]; 
       clength = Length[path]]
      ]) & @@@ Subsets[VertexList[g], {2}]; {clength, 
   path}) // AbsoluteTiming

{1.53982, {23, {"calm", "muir", "reef", "fray", "yaws", "seed",
"deaf", "fnma", "axis", "sill", "loge", "eyed", "duns", "stow",
"wart", "tint", "trig", "good", "dune", "etch", "hill", "lath",
"howl"}}}

(allPaths = 
   FindPath[g, #2, #1, Infinity, All] & @@@ 
     Subsets[VertexList[g], {2}] // Apply[Join];
  First[TakeLargestBy[allPaths, Length@Union@# &, 
    1]]) // AbsoluteTiming

{21.6151, {"calm", "muir", "reef", "fray", "yaws", "seed", "deaf",
"fnma", "axis", "sill", "loge", "eyed", "duns", "stow", "wart",
"tint", "trig", "good", "dune", "etch", "hill", "lath", "howl"}}

and another heuristic approach:

pseudoorder = 
  VertexList[
    g][[Ordering[
     Last /@ GraphEmbedding[g, "LayeredDigraphEmbedding"]]]];

MaximalBy[
  FindPath[g, Last[pseudoorder], #, Infinity, All][[-1]] & /@ 
   Take[pseudoorder, 3], Length] // First

Answer 3

I can't say that I know the combinatorics for this. Inspired by the thoughtful answer written by David G. Stork, here are some heuristic observations. Perhaps someone can write an authoritative answer and add/utilize some of the constraints presented here to speed up their searches.

Let's start by defining a function:

wordDelimitedBy[a_String, b_String] := 
 DictionaryLookup[
  StartOfString ~~ a ~~ Longest[__] ~~ b ~~ EndOfString]

---

Usage Examples

1- Words ending in "q" (none):

wordDelimitedBy[#, "q"] & /@ Alphabet[]

{{}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {},
{}, {}, {}, {}, {}, {}, {}, {}, {}}

2- Words ending in "j":

wordDelimitedBy[#, "j"] & /@ Alphabet[]

{}, {}, {}, {}, {}, {}, {}, {"haj", "hajj"}, {}, {}, {}, {}, {}, {},
{}, {}, {}, {"raj"}, {}, {}, {}, {}, {}, {}, {}, {}

Essentially no words there either.

---

To find the character tuples that do not delimit any words:

delimCounts = {First@#, Last@#, 
     Length@wordDelimitedBy[First@#, Last@#]} & /@ 
   Tuples[Alphabet[], {2}] ;
nolinks = Cases[delimCounts, {a_, b_, 0} :> {a, b}]

{{"a", "j"}, {"a", "q"}, {"a", "v"}, {"b", "j"}, {"b", "q"}, {"b",
"v"}, {"c", "j"}, {"c", "q"}, {"c", "v"}, {"d", "j"}, {"d", "q"}, {"d", "u"}, {"e", "j"}, {"e", "q"}, {"e", "v"}, {"f", "j"}, {"f", "q"}, {"f", "v"}, {"g", "j"}, {"g", "q"}, {"h", "q"}, {"h", "v"}, {"i", "j"}, {"i", "q"}, {"i", "v"}, {"i", "z"}, {"j", "j"}, {"j", "q"}, {"j", "v"}, {"k", "j"}, {"k", "q"}, {"k", "v"}, {"k", "x"}, {"l", "j"}, {"l", "q"}, {"l", "z"}, {"m", "j"}, {"m", "q"}, {"m", "v"}, {"n", "j"}, {"n", "q"}, {"n", "u"}, {"n", "v"}, {"n", "z"}, {"o", "j"}, {"o", "q"}, {"o", "v"}, {"o", "z"}, {"p", "j"}, {"p", "q"}, {"q", "b"}, {"q", "j"}, {"q", "q"}, {"q", "u"}, {"q", "v"}, {"q", "w"}, {"q", "x"}, {"r", "q"}, {"r", "u"}, {"s", "j"}, {"s",
"q"}, {"t", "j"}, {"t", "q"}, {"t", "v"}, {"u", "b"}, {"u", "j"}, {"u", "q"}, {"u", "u"}, {"u", "v"}, {"u", "z"}, {"v", "j"}, {"v", "q"}, {"v", "u"}, {"v", "v"}, {"v", "z"}, {"w", "j"}, {"w", "q"}, {"w", "u"}, {"w", "v"}, {"x", "b"}, {"x", "f"}, {"x", "h"}, {"x", "i"}, {"x", "j"}, {"x", "k"}, {"x", "l"}, {"x", "o"}, {"x", "p"}, {"x", "q"}, {"x", "r"}, {"x", "u"}, {"x", "v"}, {"x", "w"}, {"x", "z"}, {"y", "j"}, {"y", "q"}, {"y", "v"}, {"y", "x"}, {"y", "z"}, {"z", "b"}, {"z", "f"}, {"z", "j"}, {"z", "q"}, {"z", "v"}, {"z", "w"}, {"z", "x"}, {"z", "z"}}

---

In order to plot this information:

densityData = 
  delimCounts  /.  a_String :> Det@Position[Alphabet[], a];
ticks = Transpose[{Range[26], Alphabet[]}]

(Tuples[Alphabet[], {2}] //
    Partition[#, Length@Alphabet[]] &) /.
  {a_, b_} :> If[MemberQ[nolinks, {a, b}], Red, Black] //
 ArrayPlot[#
   , Frame -> True
   , FrameTicks -> {{ticks, ticks}, {ticks, ticks}}
   , FrameLabel -> {{Style["Word ends at", 16, Bold], None}
     , {Style["Word starts at", 16, Bold], None}}
   , DataReversed -> {True, False}
   , PlotLabel -> 
    Style["Constraints on setting up a chain of English words", 24, 
     Bold]
   , Mesh -> All
   , MeshStyle -> {{Dotted, Gray}, {Dotted, Gray}}
   , ImageSize -> 600
   , Epilog -> {
     {Text[Style[#3, 8, Yellow], {#2, #1} - 0.5] & @@@ densityData}
     }
   ] &

---

The solid red columns at q, j and v with near-zero counts mean that few words end there. A very small number of words start with x, y, z and that can be seen from the corresponding rows. If one lands on one of the last three columns, they will find out that the opportunities to chain words using the top three rows are limited as well.

In the English language the higher counts in certain columns can be attributed in part to grammatical constructs. I don't have a definitive break down for this observation.

For example:

d: Due to ed endings for verbs in the past tense.

g: Due to ing endings for verbs in the present continuous tense

s: Due to the plurals in the language (mostly)

r: Due to comparative forms such as greener

y: due to adverbs ending in -ly

---

As long as one does not run out of words at transposed locations, an arbitrary path can be chalked out by traversing the black squares. A simple example would be to start from q and go to p chaining and exhausting words, but since nothing ends in q, one could turn back and go back to r passing through the narrow bottleneck in the j column (at most twice) and then getting stuck soon in the last three alphabet columns.

---

An example of a manual path that can find random words (with the exception of new words that end in j, since there aren't many) is presented next.

manualpath = {{"q", "r"}, {"r", "s"}, {"s", "t"}, {"t", "u"}, {"u", 
    "g"}, {"g", "v"}, {"v", "w"}, {"w", "x"}, {"x", "y"}, {"y", 
    "a"}, {"a", "b"}, {"b", "c"}, {"c", "d"}, {"d", "e"}, {"e", 
    "f"}, {"f", "g"}, {"g", "h"}, {"h", "i"}, {"i", "h"}, {"h", 
    "j"}, {"j", "k"}, {"k", "l"}, {"l", "m"}, {"m", "n"}, {"n", 
    "o"}, {"o", "p"}};

If[Length@wordDelimitedBy[First@#, Last@#] >= 1, 
   RandomChoice@wordDelimitedBy[First@#, Last@#], {}] & /@ manualpath

{"quieter", "relights", "swankest", "trousseau", "unpromising",
"guv", "view", "wax", "xerography", "yoga", "alb", "bivouac",
"charred", "deflective", "engulf", "frightening", "gush", "hibachi",
"interfaith", "haj", "joystick", "karakul", "lam", "mouton",
"nympho", "outcrop"}

Any path that doesn't include tuples in nolinks can be chosen as long as one doesn't run out of words with the chosen delimiters.