Synonym Graphs and Word Chains
Synonym Graphs and Word Chains
This is based on Jon McLoone’s blog post “The Distance between “Zero” and “Hero”: Exploring Synonym Chains with Mathematica” at https://blog.wolfram.com/2011/03/17/the-distance-between-zero-and-hero-exploring-synonym-chains-with-mathematica/.
In[]:=
deletePhrases[data_List]:=DeleteCases[data,_String?((StringMatchQ[#,"* *"]&))]
In[]:=
deletePhrases[{"zombie","living dead"}]
Out[]=
{zombie}
In[]:=
getSynonymWords[word_]:=Union[deletePhrases[Flatten[Last/@WordData[word,"Synonyms"]]]]
In[]:=
getSynonymWords["wealthy"]
Out[]=
{affluent,flush,loaded,moneyed}
In[]:=
$SynonymGraph=Graph[Union[Flatten[Table[Sort[word#]&/@getSynonymWords[word],{word,deletePhrases[Union[WordData[]]]}]]]];
In[]:=
connectWords[vertex1_,vertex2_]:=Block[{path=FindShortestPath[$SynonymGraph,vertex1,vertex2]},If[Head[path]===FindShortestPath||path==={},Failure["InvalidRange",<|"MessageTemplate""No path between `vertex1` and `vertex2`.","MessageParameters"<|"vertex1"vertex1,"vertex2"->vertex2|>|>],Row[Riffle[path,"⟶"]]]]
In[]:=
connectWords["zero","hero"]
Out[]=
zero⟶zip⟶energy⟶push⟶force⟶wedge⟶hero
In[]:=
connectWords["words","action"]
Out[]=
words⟶speech⟶address⟶treat⟶process⟶action
In[]:=
connectWords["peon","chief"]
Out[]=
peon⟶drudge⟶dig⟶gibe⟶check⟶control⟶master⟶chief
In[]:=
connectWords["drunk","sober"]
Out[]=
drunk⟶inebriate⟶thrill⟶bang⟶strike⟶scratch⟶grave⟶sober
In[]:=
connectWords["stupid","clever"]
Out[]=
stupid⟶dullard⟶bore⟶gauge⟶guess⟶supposition⟶assumption⟶presumption⟶given⟶apt⟶clever
In[]:=
connectWords["geek","cool"]
Out[]=
geek⟶eccentric⟶case⟶shell⟶beat⟶quiver⟶chill⟶cool
In[]:=
connectWords["sample","addiction"]
Out[]=
sample⟶try⟶adjudicate⟶resolve⟶resolution⟶settlement⟶colony⟶dependency⟶addiction
In[]:=
connectWords["lazy","wealthy"]
Out[]=
lazy⟶otiose⟶superfluous⟶spare⟶plain⟶kick⟶flush⟶wealthy
In[]:=
connectWords["problem","solution"]
Out[]=
problem⟶job⟶line⟶origin⟶root⟶solution
In[]:=
connectWords["back","front"]
Out[]=
back⟶stake⟶bet⟶look⟶front
In[]:=
$BestSynonymGraph=Subgraph[$SynonymGraph,First[ConnectedComponents[$SynonymGraph]]];
In[]:=
VertexCount[$BestSynonymGraph]
Out[]=
19754
This takes a while to run.
In[]:=
eccentricityData={VertexEccentricity[$BestSynonymGraph,#],#}&/@VertexList[$BestSynonymGraph];
In[]:=
Take[Sort[eccentricityData],-50]
Out[]=
{{22,repent},{22,salaried},{22,schmaltzy},{22,schmalzy},{22,seduction},{22,self-command},{22,self-possession},{22,self-will},{22,sentimental},{22,slushy},{22,solemnisation},{22,solemnization},{22,soppy},{22,soupy},{22,stipendiary},{22,taking},{22,unimportance},{22,vulcanised},{22,vulcanized},{22,willpower},{23,atone},{23,bullheadedness},{23,compensated},{23,drizzly},{23,gainful},{23,humility},{23,lowness},{23,monomania},{23,obstinacy},{23,obstinance},{23,outspokenness},{23,ownership},{23,paid},{23,pickings},{23,pigheadedness},{23,remunerated},{23,sodden},{23,straightness},{23,stubbornness},{24,aby},{24,abye},{24,dejectedness},{24,dispiritedness},{24,downheartedness},{24,expiate},{24,heterosexualism},{24,heterosexuality},{24,low-spiritedness},{24,mulishness},{24,nonrecreational}}
eccentricWords=Cases[eccentricityData,{24,word_}->word]
Out[]=
{aby,abye,expiate,nonrecreational,mulishness,dejectedness,dispiritedness,downheartedness,low-spiritedness,heterosexualism,heterosexuality}
In[]:=
TableFormTable[GraphDistance[$BestSynonymGraph,i,j],{i,eccentricWords},{j,eccentricWords}]/.{24->"●",_Integer->""},TableHeadings->eccentricWords,Rotate#,&/@eccentricWords,TableAlignments->{Right,Bottom},TableSpacing->{1,2}
π
2
Out[]//TableForm=
aby | abye | expiate | nonrecreational | mulishness | dejectedness | dispiritedness | downheartedness | low-spiritedness | heterosexualism | heterosexuality | |
aby | ● | ● | ● | ● | |||||||
abye | ● | ● | ● | ● | |||||||
expiate | ● | ● | ● | ● | |||||||
nonrecreational | ● | ● | |||||||||
mulishness | ● | ● | |||||||||
dejectedness | ● | ● | ● | ||||||||
dispiritedness | ● | ● | ● | ||||||||
downheartedness | ● | ● | ● | ||||||||
low-spiritedness | ● | ● | ● | ||||||||
heterosexualism | ● | ● | |||||||||
heterosexuality | ● | ● |
In[]:=
connectWords["dejectedness","expiate"]
Out[]=
dejectedness⟶lowness⟶lowliness⟶obscureness⟶abstruseness⟶profoundness⟶astuteness⟶perspicacity⟶judgement⟶discernment⟶appreciation⟶hold⟶make⟶work⟶sour⟶sourness⟶moroseness⟶glumness⟶gloominess⟶sadness⟶sorrow⟶regret⟶repent⟶atone⟶expiate
In[]:=
connectWords["mulishness","heterosexuality"]
Out[]=
mulishness⟶obstinacy⟶self-will⟶self-control⟶self-denial⟶denial⟶demurrer⟶demur⟶except⟶exclude⟶eject⟶discharge⟶fire⟶burn⟶bite⟶sharpness⟶asperity⟶grimness⟶luridness⟶paleness⟶fairness⟶candor⟶directness⟶straightness⟶heterosexuality
In[]:=
connectWords["nonrecreational","heterosexuality"]
Out[]=
nonrecreational⟶paid⟶paying⟶remunerative⟶moneymaking⟶mercenary⟶free-lance⟶independent⟶main⟶primary⟶basal⟶base⟶fundament⟶butt⟶edge⟶sharpness⟶asperity⟶grimness⟶luridness⟶paleness⟶fairness⟶candor⟶directness⟶straightness⟶heterosexuality
In[]:=
HamiltonianGraphQ[$BestSynonymGraph]
Out[]=
False
So the challenge would be to find the largest Hamiltonian subgraph of this graph. Since the result will probably form a synonym chain that is thousands of words long, and too big for this blog, I will leave that as a challenge to the reader!
In[]:=
Select[ConnectedComponents[$SynonymGraph],HamiltonianGraphQ[#]&]
Out[]=
{}
None of the subgraphs of the synonym graph are Hamiltonian.
Here is the second smallest graph.
In[]:=
$SecondBestSynonymGraph=Graph[Subgraph[$SynonymGraph,Part[ConnectedComponents[$SynonymGraph],2]],VertexLabels->"Name",ImageSize->Full]
Out[]=
