Finding Anagrams of given length from DictionaryLookup

Question

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]

Answer 1

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

Answer 2

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.

Answer 3

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"}}

*)

Answer 4

Idea from this tweet by @fermatslibrary

char2primerule = Normal[
  Join[KeyMap[ToUpperCase, #], #] &@
     AssociationThread[#, Array[Prime, Length[#]]] &@
   CharacterRange["a", "z"]
  ]

word2product[s_String] := 
 Times @@ ReplaceAll[Characters[s], char2primerule]


anagrams[n_] := Select[
  GatherBy[
   DictionaryLookup[StringExpression @@ Table[LetterCharacter, {n}]]
   , word2product]
  , Length[#] > 1 &
  ]

---

Not related to that algorithm, but for completitude:

To find an Anagram for a particular word

anagramsto[s_String] := 
 DictionaryLookup[AnyOrder[Sequence @@ Characters[s]]
 , IgnoreCase -> True
 ]

or

anagramsto[s_String] := 
Module[{c = Sort[Characters[s]]},
 DictionaryLookup[x__ /; Sort[Characters[x]] == c]]