Word puzzles are fun and educational forms of entertainment that have many variations ranging all the way from scrabble and crosswords to hangman and word chains. One of the most famous word games is the Word Ladder puzzle, which was invented by Lewis Caroll back in 1877. I myself am a big lover of those kind of games and having the opportunity to participate in Wolfram Summer School and being a Mathematica newbie, I decided to take the chance and make my own word puzzle.

The main aim of the project was to create a spinoff of a classic childhood Word Ladder game using a non-playable character (NPC) bot. The project is based on concepts of machine learning and graph theory, and consists of three parts:

• creating the front-end interface and game engine
• analyzing letter change frequency using graphs
• implementing the scoring system

A graph of three letter words

The game starts when the player is given the option of choosing the length of the word, after what bot randomly selects a word of specified length from database. Then both player and the bot each take turns and change one letter at a time (e.g. room-doom-dorm). Whoever uses all of the possible words is the winner.

Selecting Vocabulary

The first step is to create a database of words.This is done by selecting words of appropriate length from WordData, taking as a reference Jon McLoone's article. I am also filtering out profanity:

badWords = Import["https://raw.githubusercontent.com/LDNOOBW/List-of-Dirty-Naughty-Obscene-and-Otherwise-Bad-Words/master/en", "List"];
newWords = Complement[WordData[], badWords];

myWords[n_]:=
    myWords[n]=
    DeleteCases[Cases[newWords, word_String/;
       (StringLength[word]===n && StringMatchQ[word, RegularExpression["[a-z]+"]])],"-Redacted word-"]

Functions

Function neighborsQ uses HammingDistance to find if the words are neighbors, i.e. differ by one letter and have the same length.

neighborsQ [word1_, word2_]:= HammingDistance[word1, word2]==1 && StringLength[word1] === StringLength[word2];

Example:

In[]: = neighborsQ["love", "live"]
Out[] = True

 In[]: = neighborsQ["cats", "dogs"]
Out[] =  False

Function strNeighb uses machine learning function Nearest to find the neighbors of the word:

strNeighb[word_String]:=Rest[Nearest[myWords[n],word,{All,1}]];

Example:

 In[]: = strNeighb["bell"]

Out[] =  {"ball", "belt", "bill", "boll", "bull", "cell", "dell", "fell", "hell", "jell", "sell", "tell", "well", "yell"}

Creating a dialog window for choosing the length of the words:

In[]:= n = ChoiceDialog["Pick the number of letters",{"4 letters"-> 4, "5 letters"-> 5, "6 letters"-> 6}]

"Easter eggs":

jokes = {"I was going to look for my missing watch, but I could never find the time.", 
 "I think my neighbor is stalking me as she's been googling my name on her computer. I saw it through my telescope last night.",
 "I wanna make a joke about sodium, but Na..", "Why did the scientist install a knocker on his door? He wanted to win the No-bell prize!", 
"Shout out to all the people wondering what the opposite of in is.", 
"Q: How do astronomers organize a party? 
   A: They planet."};


If[in === "joke", Print[RandomChoice[jokes]]];

The engine

As soon as the game starts, this message is printed and a choice dialog appears:

Print["Welcome to  
???
???
Word
???
???
???
???
ladders!
???
???
??? "];
Print["Rules: You're given a word randomly chosen by the bot.
Change one letter in the word and create a chain. 
You cannot use proper names, abbreviations and already used words. Whoever uses all of the words is the winner. Have fun! :)"];
n = ChoiceDialog["Pick the number of letters",{"3 letters"->3, "4 letters"->4, "5 letters"->5 }];

Then bot randomly chooses a word of specified length and user inputs a word. The While loop checks whether the word belongs to the list of available words and whether it is neighboring with the previous word. If the answer to one of these is False, the user has to input a word again:

listall={};
ran = RandomChoice[myWords[n]]; 
Print["Bot: ", ran];
Speak[ran];
in = InputString["My word is " <> ran <>". Your turn now: "];
listall = Append[listall, ran];
While[ContainsNone[myWords[n],{in}]|| ContainsAny[listall, {in}] || neighborsQ[in, Last[listall]]===False,
    Print["Huh, it looks like you just typed an invalid or already used word. Try again."];
       in = InputString["My word is " <> ran <>". Your turn now: "]];

Next While loop also checks whether the word is available and whether it is previous word's neighbor. If checks winning conditions to quit the game when necessary. If user's input is invalid he is asked to type in a word again by using Label and Goto function. Speak function vocalizes input and the output:

While[
ContainsAny[myWords[n], {in}] && neighborsQ[ran, in] && ContainsNone[listall, {in}],
    listall = Append[listall, in];
    Print["Player: ", in];
    Speak[in];
    out = RandomChoice[strNeighb[in]];
    While[ContainsAny[listall, {out}],
       DeleteCases[strNeighb[in], out];
       out = RandomChoice[strNeighb[in]];
       If[ContainsAll[listall,strNeighb[in] ], Print["You won this time..."];  
       Abort[]]
    ];
    listall = Append[listall, out];

    If[Length[Complement[strNeighb[in], listall]]===0,
       Print["You win"];
       Speak["You win"];
       Abort[];
       ] 

    If[Length[Complement[strNeighb[out], listall]===0],
       Print["No more choice. I win"];
       Speak["No more choice, I win"];
       Print["Bot: ",out];
       Abort[];
        ]

    Print["Bot: ", out];
    Speak[out];
    ran = out;
    Label[begin];
    in = InputString["My word is " <> out <>". Your turn now: "];

    If[in === "joke", Print[RandomChoice[jokes]]];

    If[ContainsNone[myWords[n], {in}]|| ContainsAny[listall, {in}] || neighborsQ[in, Last[listall]] === False,
       Print["Huh, it looks like you've used an invalid or already used word"]; 
       Goto[begin];
       ]
];

Prints the amount of words used during the game:

Print["Game over after "<> ToString[Length[listall]]<>" words"];
Speak["Game over after "<> ToString[Length[listall]]<>" words"];

Letter change frequency

The aim of this part is to analyze the letter change frequency in words of different length, and later based on that implement a scoring system by assigning the lowest score to the most frequent change and evaluate other scores relative to it. Whoever manages to get the highest score by the end of the game is the winner.

three = myWords[3];
four = myWords[4];
five = myWords[5];

Building graphs

Graph is the visualization of the matrix which in its turn is based on the principle of finding word's neighbors by Hamming Distance and assigning True if their distance is equal to one and False otherwise. Words of length three:

matrixThree = 
  Clip[Outer[HammingDistance, three, three], {0, 1}, {0, 0}];

graphThree = AdjacencyGraph[three, matrixThree,
  VertexLabels -> Placed["Name", Tooltip],
  GraphStyle -> "LargeNetwork"]

Some of three-letter words have only one neighbor, while others like "gnu" or "ugh" do not have neighbors at all.

Words of length four:

matrixFour = Clip[Outer[HammingDistance, four, four], {0, 1}, {0, 0}];

graphFour = AdjacencyGraph[four, matrixFour,
  VertexLabels -> Placed["Name", Tooltip],
  GraphStyle -> "LargeNetwork"]

Words of length five:

matrixFive = Clip[Outer[HammingDistance, five, five], {0, 1}, {0, 0}];

graphFive = AdjacencyGraph[five, matrixFive,
  VertexLabels -> Placed["Name", Tooltip],
  GraphStyle -> "LargeNetwork"]

Getting the edges and extracting frequency data

To get the list of connected words I am extracting the edges by using EdgeListFunction:

edgeThree = EdgeList[graphThree];
edgeFour = EdgeList[graphFour];
edgeFive = EdgeList[graphFive];

Next from the list of all words I am selecting the "flipped" letters, tallying them and sorting in descending order:

data[3] = Reverse[SortBy[Tally[Sort /@  Flatten[Cases[SequenceAlignment[#1, #2], _List] & @@@ edgeThree,1]], Last]];

Similarly:

data[4] =Reverse[SortBy[Tally[Sort /@ Flatten[Cases[SequenceAlignment[#1, #2], _List] & @@@ edgeFour,1]], Last]];
data[5] = Reverse[SortBy[Tally[Sort /@ Flatten[Cases[SequenceAlignment[#1, #2], _List] & @@@ edgeFive,1]], Last]];

The most common and least common flips in three-, four- and five-letter words correspondingly:

Scoring System and the new engine

Based on the letter frequency data, I am going to change game mechanics and implement a scoring system. The highest index is 169, thus taking the overall score equal to 170, I will assign the highest score to the least possible letter change combination. To do so I am creating function pos that takes each letter pair from data[n] and function index that takes it's second parameter. Function seqAlig gives the list of the changed letters:

In[]:= seqAlig["dummy", "tummy"]
Out[]= {{"d", "t"}}

pos = First[Flatten[Position[data[n], letters]]];
index = data[n][[pos,2]];

The overall structure of the engine is almost the same. The game is going to continue until either there are no available words or score is over 5000:

Print["Welcome to  
???
???
Word
???
???
???
???
ladders!
???
???
??? "];
Print["Rules: You're given a word randomly chosen by the bot.
Change one letter in the word and create a chain. 
You cannot use proper names, abbreviations and already used words. Whoever uses all of the words is the winner. Have fun! :)"];
n = ChoiceDialog["Pick the number of letters",{"3 letters"->3, "4 letters"->4, "5 letters"->5 }];
scorebot=0;
scoreplay=0;

listall={};
ran = RandomChoice[myWords[n]]; 
Print["Bot: ", ran];
Speak[ran];
in = InputString["My word is " <> ran <>". Your turn now: "];
listall = Append[listall, ran];

While[ContainsNone[myWords[n],{in}]|| ContainsAny[listall, {in}] || neighborsQ[in, Last[listall]]===False,
    Print["Huh, it looks like you just typed an invalid or already used word. Try again."];
       in = InputString["My word is " <> ran <>". Your turn now: "]]

seqAlig = Cases[SequenceAlignment[#1,#2],_List]&;

While[
ContainsAny[myWords[n], {in}] && neighborsQ[ran, in] && ContainsNone[listall, {in}],
    Print["Player: ", in];
    Speak[in];

    listall = Append[listall, in];
    letters = Sort[Flatten[seqAlig[ran, in]]];
    pos = First[Flatten[Position[data[n], letters]]];
    index = data[n][[pos,2]];
    score = 170-index;
    scoreplay = scoreplay + score;
    Print["Bot: ",scorebot];
    Print["Player: ",scoreplay];

    out = RandomChoice[strNeighb[in]];
    While[ContainsAny[listall, {out}],
       DeleteCases[strNeighb[in], out];
       out = RandomChoice[strNeighb[in]];
       If[ContainsAll[listall,strNeighb[in] ], Print["No more words :'("];  (*If all of the word's neighbors have already been used, player wins*)
       Abort[]]
    ];

    If[Length[Complement[strNeighb[in], listall]]===0,
       Print["No more words"];
       Speak["No more words"];
       Abort[];] (*If player's word has no neighbors, player wins*)

    If[Length[Complement[strNeighb[out], listall]===0],
       Print["No more words"];
       Speak["No more words"];
       Print["Bot: ",out];
       Abort[];] (*If bot's word has no neighbors, bot wins*)

    Print["Bot: ", out];
    Speak[out];

    listall = Append[listall, out];
    letters = Sort[Flatten[seqAlig[in, out]]];
    pos = First[Flatten[Position[data[n], letters]]];
    index = data[n][[pos,2]];
    score = 170-index;
    scorebot = scorebot + score;
    Print["Bot: ",scorebot];
    Print["Player: ",scoreplay];

    ran = out;
    Label[begin];
    in = InputString["My word is " <> out <>". Your turn now: "];

    If[scorebot >= 5000 || scoreplay >= 5000, 
       Abort[];]

    If[in === "joke", Print[RandomChoice[jokes]]];

    If[ContainsNone[myWords[n], {in}]|| ContainsAny[listall, {in}] || neighborsQ[in, Last[listall]] === False,
       Print["Huh, it looks like you've used an invalid or already used word"]; 
       Goto[begin];
       ]
];


    If[scorebot>scoreplay,
        Print["You lost. Your score is " <> ToString[scoreplay] <> " points."];
        Speak["You lost. Your score is " <> ToString[scoreplay] <> " points."]];
    If[scorebot<scoreplay, 
        Print["Congratulations! You won! Your score is " <> ToString[scoreplay] <> " points."];
        Speak["Congratulations! You won! Your score is " <> ToString[scoreplay] <> " points."]];
    If[scorebot==scoreplay, 
        Print["It's a tie... Your score is " <> ToString[scoreplay] <> " points."];
        Speak["It's a tie... Your score is " <> ToString[scoreplay] <> " points."]];

    Print["Game over after "<> ToString[Length[listall]]<>" words"];
    Speak["Game over after "<> ToString[Length[listall]]<>" words"];

Further improvements and comments about the code are very much appreciated.Thank you!

Attachments: