How could I generate words starting with P,h,D?

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] &];

filterWordsByPart,

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


And this is a sample output:

-
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
From the old joke: Piled Higher, Deeper – Fred Kline May 19 '14 at 12:52
When I was in graduate school I worked for a city as a street maintenance worker. When I told my boss that I was working on a Ph.D., he replied that he had one of those in his truck: a post hole digger. – Jim Baldwin Aug 3 '15 at 22:55

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,
StringMatchQ[pairs[[All, 1]], "p" ~~ __, IgnoreCase -> True] &&
StringMatchQ[pairs[[All, 2]], "h" ~~ __, IgnoreCase -> True]]];

hdpairs = Pick[pairs,
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" *)

-
Text can also be taken from Project Gutenberg – ssch Sep 25 '13 at 13:23
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
How come with Mathematica 10.0.1 under OS X I get results with the last word being "and" ? As if Except[] doesn't work. – Zet Nov 8 '14 at 2:25

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

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

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


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"*)

-