“Daddy, let’s play this word game that I learnt at school!
Oh, and by the way, let’s skip the boring part where I tell you the rules.
Instead let’s just play and when you make a mistake I’ll tell you.”

I’ll be a bit kinder and explains the rules at the start: You have to pick a letter so that the remaining letters still form a word. (So in the first round, I could have picked the letter ‘t’, or ‘l’, which would result in the words ‘starling’ or ‘starting’, respectively.)

You win the game if you correctly identify a sequence of letters to eliminate at each state, so that your last valid word is only a single letter long. For example, here is one way you can produce a winning sequence:

startling, starting, staring, string, sting, sing, sin, in, I.

She then said that her teacher had told the class that this was the longest word where you can go all the way down to 1-letter. Being as curious as I am, I thought I would try to verify this. Furthermore, I was intriguied as to what other words had this characterisitic.

Over the last two decades I have mainly used Mathematica for its unparalleled numerical and algebraic functionality (eg I used it quite extensively during my honours and PhD years in theoretical physics.) However, more recently I have been trying to leverage some of the non-mathematical functionality in it. I thought that this was an execellent excuse to use some of its English language capabilities.

Ever since v6.0, the word data has now been integrated into the core kernel of Mathematica, so you don’t need to import any additional packages. Although, there are some incredibly rich functions such as WordData which can output high-levels of word data. In this case though, I will just use the core function is DictionaryLookup[w] which returns w if the input string is found in the dictionary, and a null list otherwise.

vocabulary = DictionaryLookup[];

isWordValid[myWord_] := isWordValid[myWord] =
  DictionaryLookup[myWord, IgnoreCase -> True] != {};

wordParts[myWord_] := wordParts[myWord]=
  Table[StringDrop[myWord, {i}], {i, StringLength[myWord]}];

The first thing to note is the slightly unusual syntax

myFunction[args_] := myFunction[args] = returnSomething

instead of the simpler and far more common

myFunction[args_] := returnSomething

The difference is that the latter syntax will evaluate myFunction
each time, whereas the first format will store the value (in myFunction[.]) and use this value the next time it is invoked. The most useful time to use this syntax is when repeated unchanging evaluations are required which is very common in recursive definitions like this.

The second thing to notice is that wordParts keeps all the remaining letters in their original order. There are other variants of this spelling challenge where you are allowed/required to rearrange the letters. In this case, the following function would product the requisite set of possible words.

wordPartsWithRearrangement[myWord_] :=
  wordPartsWithRearrangement[myWord] =
    Map[StringJoin,
      Permutations[
        Characters[myWord],{StringLength[myWord]-1}
       ]
    ]

The essential part to this particular solution is creating a recursive function findSequences that finds all full-length (ie. winning) sequences.

Then, just to speed things up we limit ourselves to trying to find the long words that have full-length sequences. Due to the recursive algorithm that we used, we result is a tree with each branch being of varying lengths (all the non-null ones are full length), so we then flatten it out. We could either flatten it by looking at its structure and taking all non-null elements that are of full-length, however, I thought the simplest technique was to exploit the fact that I have made every proper sequence end in the “!” character.

findSequences[wordPath_, myWord_] :=
  findSequences[wordPath, myWord] =
  Module[
   {newPath},
   newPath = Join[wordPath, {myWord}];
   If[ StringLength[myWord] == 1,
    Join[newPath, {"!"}],
    Map[findSequences[newPath, #] &,
     Select[wordParts[myWord], isWordValid[#] &]]
    ]
   ];

flattenTree[myTree_] :=
  Extract[myTree,Map[Drop[#, -1]&,Position[myTree,"!"]]] ;

fullSequence[myWord_] := fullSequence[myWord] =
  flattenTree[findSequences[{}, myWord] ]
;

minimumWordLength = 9;
longWords =
  Select[vocabulary, StringLength[#] >=  minimumWordLength &];
universalList =
  Flatten[Map[fullSequence,longWords],1];

The universalistList indicates that there are 52 nine-letter words that have full sequences, however, a typical one looks like this:

threadier, threader,treader, trader,trade,trad,tad,ad,a,!

At first glance, it appears that there was mistake in my code, given some of these words. However, if you grab look in a dictionary (or better still, use Mathematica’s WordData[.] function!) you will actually find all of these words.

So although some people will be adamant that this is a fully correct soltution, I was also pragmatic about the idea that I wanted to find other words that her Primary School teacher could have used instead.
I don’t think that she, or the kids would think that the word ‘trad’ was reasonable. So what follows is a fully subjective list of words that I would think would be unfair, inappropriate, etc to expect or want the child to use in finding a solution. As I said, I fully acknowledge that this list is subjective and maybe you and your kids are smarter than me, and that’s fine by me.

uncommonWords = {
  "ac", "ad", "ans", "aping", "ashe", "ates", "bi",   "chi", "chis", "dis", "downing", "eking",   "fan", "fran", "id", "ines", "ins",  "la", "lan", "latte", "lea", "lin",   "mi", "mit", "miter",   "oping",  "pas", "pater", "paters", "pates", "peaces",   "peking", "pieing", "piing", "piking", "platte",  "prattlers","prig", "raping", "rappings", "ratters",   "roweling", "rowling",  "san", "sate", "sating", "sine", "sines", "siting",   "slitter","spritzes", "stalkings", "stan", starvings","stringer", "stringers", "stringier",   "ta", "tam", "tate", "ti", "whit", "withe", "withs"
};

usesOnlyCommonWords[mySequence_] :=
  Intersection[uncommonWords, ToLowerCase[mySequence]] == {};

finalSequences = Select[
  universalList, usesOnlyCommonWords[#] &
];

finalWordList  = Union[finalSequences[[All, 1]] ];

Final Result

If you are happy to include the word ‘siting’, then “splittings” is actually the longest word with this special characteristic.

However, if you don’t ‘like’ this word, then the teacher was right “startling” really is the longest word. However, with that said, we now know that there are four other equal winners: cleansers, roadsters, splatters, and starlings.

I gave these 4 additional words to my daughter and she solved them in about five minutes – much less time than I took to write the Mathematica code, and far less time that I took to write this post. But I am happy, and thought it a worthwhile and enjoyable exercise for all.

___

If you liked this post, please join me at Google+ or Quora.
For more information about me, visit LinkedIn or here.