Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

A friend of mine is a PhD candidate and posted a picture on Facebook with funny words starting with 'p', 'h' and 'd' like "Please hire. Desperate" or "Permanent head Damage". I thought I could try and programmatically generate some word combinations with Mathematica.

Here is my version. Most of the results are meaningless, but occasionally a good combination will show up like "panegyric happiness date".

  1. Could it be improved (i.e. increase its signal/noise ratio)?
  2. Could the following construct be condensed {"." -> "", ";" -> "", "," -> "", ... -> ""? Schematically: {".", ";", ","} - >""
  3. The reason I used StringMatchQ with Map[] is because I didn't know how to group the results based on the first letter of the words, e.g. {please, hire, permanent, damage, head, desperate} -> {{please, permanent}, {hire, head}, {damage, desperate}}`.

Also, I used words from DictionaryLookup[], picking those with the most meanings (to increase the likelihood of a meaningful combination), but the results were worse.

Here is my code:

ClearAll["Global`*"];

allWords = 
  ExampleData[{"Text", "PrideAndPrejudice"}, "Words"] // DeleteDuplicates;

phdWords = Pick[
     allWords,
     StringMatchQ[allWords, #]] & /@ {"p" ~~ __, "h" ~~ __, "d" ~~ __};

phdWords =
  StringReplace[#,
     {"." -> "", ";" -> "", "," -> "", "!" -> "", "?" -> "", 
      "\"" -> ""}] & /@ phdWords;

filterWordsByPart[wordList_, part_] :=
  Select[
   wordList,
   MemberQ[
     WordData[#, "PartsOfSpeech"], part] &];

finalWords = MapThread[
   filterWordsByPart,
   {phdWords, {"Adjective", "Noun", "Noun"}}];

Table[
  Flatten@(RandomSample[#, 1] & /@ finalWords),
  {20}] // Grid[#, Frame -> All] &

And this is a sample output:

enter image description here

share|improve this question
2  
This also reminds me of a fiendishly clever oneliner from 2011 by William Wu. –  Yves Klett Sep 25 '13 at 11:46
    
actually, WordData might just be the thing here, too... –  Yves Klett Sep 25 '13 at 12:38
add comment

2 Answers

up vote 12 down vote accepted

To find out what words go well together one can sample some text from ExampleData and pick only words that have at least been mention together pairwise before.

sample = ToLowerCase@StringJoin[{
    ExampleData[{"Text", "AliceInWonderland"}], 
    ExampleData[{"Text", "OnTheNatureOfThingsEnglish"}],
    ExampleData[{"Text", "OriginOfSpecies"}],
    ExampleData[{"Text", "USConstitution"}]}];
words = StringCases[sample, WordCharacter..];

(* All adjacent words {word1, word2} *)
pairs = Partition[words, 2, 2, 1];

phpairs = Pick[pairs,
   Thread[
    StringMatchQ[pairs[[All, 1]], "p" ~~ __, IgnoreCase -> True] &&
    StringMatchQ[pairs[[All, 2]], "h" ~~ __, IgnoreCase -> True]]];

hdpairs = Pick[pairs,
   Thread[
    StringMatchQ[pairs[[All, 1]], "h" ~~ __, IgnoreCase -> True] &&
    StringMatchQ[pairs[[All, 2]], "d" ~~ __, IgnoreCase -> True]]];

(* Filter out {"p","h"} pairs that have no corresponding {"h","d"} *)
phpairs = Select[phpairs, MemberQ[hdpairs[[All, 1]], #[[2]]] &];

After that initialization run this a few times:

(* Too many boring ones with had/has/have *)
ph = RandomChoice[Cases[phpairs, {_, Except["had" | "has" | "have"]}]];
hd = RandomChoice@Cases[hdpairs, {Last@ph, _}];
StringJoin[{First@ph, " ", First@hd, " ", Last@hd}]


(* Example results:
 "published how different"
 "person having diverged"
 "perish herself down"
 "pleasure hath dropped"
 "pities his death"
 "plants higher degree" *)
share|improve this answer
2  
Text can also be taken from Project Gutenberg –  ssch Sep 25 '13 at 13:23
1  
I pulled 30 books at random from PG, capitalization mine: "Permanent happiness? Depends", "Peace hitherto: Despairing", "possible hurt done", "Past hope. Despair", "poor hard duty", "play heavy drinking", "pretty hot discussions", "peasants high degree", "passed having died" I filtered about 50% of the results. –  ssch Sep 25 '13 at 20:10
add comment

DictionaryLookup ain´t so bad (I like "Paleozoic haircuts difficulties"):

{a, b, c} = DictionaryLookup[# ~~ ___] & /@ {"P", "h", "d"};

Grid[Transpose[RandomChoice[#, 10] & /@ {a, b, c}]]

Mathematica graphics

As for filtering, what about (directly from tutorial/StringPatterns):

StringCases["a6;b23c456;R", LetterCharacter]
(*{"a", "b", "c", "R"}*)

or another variety to keep whitespaces:

StringReplace["a6 ;b23c:456 , R a", Characters[";,:"] -> ""]
(*"a6 b23c456  R a"*)
share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.