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.

What I'm trying to find are the 4 letter words in the mathematica dictionary that have the most anagrams and the amount of anagrams these have each.

But I can't seem to find all the 4 letter words in the mathematica dictionary. My output only results in 3-8 letter words. Input is below

 wordperms =Flatten[Map[DictionaryLookup,Map[StringJoin, Permutations[Characters[#]]]]] &;
 words = DictionaryLookup[];
 sorted = Sort[Map[Sort, Map[Characters, words]]];
 Part[Select[Tally@sorted, Part[#, 2] > 4 &], All, 1];
 found = Part[Select[Tally@sorted, Part[#, 2] > 4 &], All, 1];
 Map[wordperms, found]
share|improve this question

3 Answers 3

This is an interesting puzzle. I think, though, you should restrict yourself to only words of length 4, to save processing time, as follows:

words = DictionaryLookup[Repeated[CharacterRange["a", "z"], {4}]];

where I used CharacterRange to eliminate proper names and contractions. This has the side effect that all accent marks, umlauts, etc. are also removed. As to creating the actual anagram list, my solution involves creating a hash table, of sorts.

ClearAll[anagrams];
SetAttributes[anagrams, Orderless];
anagrams[__] := {};
anagrams[s_String] := anagrams[Sequence @@ Characters[s]]

where these initial definitions of anagrams provides some helper code. To use this as a hash table, we need to feed in the words, as follows

(anagrams[Sequence @@ Characters[#]] = {#}~Join~anagrams[#]) & /@ words

It isn't the most elegant construction. For illustration sake, let

words = {"hat", "cat", "tac"}

then

DownValues@anagrams
(* 
{HoldPattern[anagrams["a", "c", "t"]] :> {"tac", "cat"}, 
 HoldPattern[anagrams["a", "h", "t"]] :> {"hat"}, 
 HoldPattern[anagrams[s_String]] :> anagrams[Sequence @@ Characters[s]], 
 HoldPattern[anagrams[__]] :> {}}
*)

So, after running it on the real set of words, we just need to extract the data:

data = Cases[DownValues@anagrams, 
 HoldPattern[Verbatim[HoldPattern][anagrams[a : Repeated[_, {4}]]] :> vals_] :> 
 {a} -> vals, Infinity];

and process it

Reverse[SortBy[data, Length@Last[#] &]][[;; 10]]
(*
{{"a", "e", "s", "t"} -> {"teas", "seat", "sate", "etas", "eats", "east", "ates"}, 
{"o", "p", "s", "t"} -> {"tops", "stop", "spot", "pots", "post", "opts"}, 
{"o", "s", "t", "w"} -> {"wost", "twos", "tows", "swot", "stow"}, 
{"a", "p", "r", "t"} -> {"trap", "tarp", "rapt", "prat", "part"}, 
{"a", "l", "s", "t"} -> {"slat", "salt", "lats", "last", "alts"}, 
{"a", "i", "l", "r"} -> {"rial", "rail", "lira", "liar", "lair"}, 
{"a", "e", "l", "s"} -> {"seal", "sale", "leas", "lase", "ales"}, 
{"i", "n", "p", "s"} -> {"spin", "snip", "pins", "nips"}, 
{"i", "k", "n", "s"} -> {"skin", "sink", "kins", "inks"}, 
{"h", "s", "t", "u"} -> {"tush", "thus", "shut", "huts"}}
*)

To make the process above a little less ad-hoc,

Clear[findAnagrams];
findAnagrams[words:{__String}]:=
Block[{anagrams, data},
 SetAttributes[anagrams, Orderless];
 anagrams[__] := {};
 anagrams[s_String] := anagrams[Sequence@@Characters[s]];
 (anagrams[Sequence@@Characters[#]] = {#}~Join~anagrams[#])& /@ words;
 Cases[DownValues@anagrams, 
    HoldPattern[Verbatim[HoldPattern][anagrams[a__String]]:> vals_]:> {a}-> vals, 
    Infinity]
]
share|improve this answer
    
I will have to reread this one over and over again since I'm not sure what a few functions mean, but I will look them up, thanks. –  jas Oct 25 '13 at 21:22
    
The answers to this question provide a good foundation for what DownValues and its siblings do. –  rcollyer Oct 25 '13 at 22:33

You can also do it using GatherBy:

GatherBy[DictionaryLookup[Repeated[_, {4}]], Composition[Sort, Characters, ToLowerCase]] /. 
    {_} -> Sequence[]
(* {{"abbe", "babe"}, {"Abby", "baby"}, {"abed", "bade", "bead"}, 
    {"Abel", "able", "bale", "Bela", "Elba"}, {"abet", "bate", "beat", "beta"}, 
    << big list >> *)

Of course, this also includes proper names, leading to duplicates such as {"will", "Will"} and several others, but it should be a trivial matter to weed them out.

share|improve this answer
    
If I did it this way, to get rid of the duplications, would I be able to use DeleteDuplicates? –  jas Oct 25 '13 at 21:07
TakeWhile[Reverse@Map[StringJoin, 
  SortBy[GatherBy[DeleteDuplicates[ ToLowerCase[Characters[DictionaryLookup[x_ ~~ y_ ~~ z_ ~~ w_]]]],
                 Union], 
        Length], {2}],
 Length@# > 5 &]


(*

{{"ales", "elsa", "lase", "leas", "lesa", "sale", "seal"}, 
 {"ates", "east", "eats", "etas", "sate", "seat", "teas"}, 
 {"alts", "last", "lats", "lsat", "salt", "slat"}, 
 {"asap", "asps", "paps", "pass", "saps", "spas"}, 
 {"eels", "ells", "else", "lees", "less", "sell"}, 
 {"opts", "post", "pots", "spot", "stop", "tops"}, 
 {"sets", "sett", "stet", "tees", "tess", "test"}}

*)
share|improve this answer
    
I like this one, but if I did it this way, if I changed the 5 at the end, my nested list would continue to increase though. –  jas Oct 25 '13 at 21:22

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.