10
$\begingroup$

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]
Improve this question
$\endgroup$
0
11
$\begingroup$

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]
]
Improve this answer
$\endgroup$
2
  • $\begingroup$ 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. $\endgroup$ – jas Oct 25 '13 at 21:22
  • $\begingroup$ The answers to this question provide a good foundation for what DownValues and its siblings do. $\endgroup$ – rcollyer Oct 25 '13 at 22:33
6
$\begingroup$

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.

Improve this answer
$\endgroup$
1
  • $\begingroup$ If I did it this way, to get rid of the duplications, would I be able to use DeleteDuplicates? $\endgroup$ – jas Oct 25 '13 at 21:07
4
$\begingroup$ 
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"}}

*)
Improve this answer
$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$ – jas Oct 25 '13 at 21:22
2
$\begingroup$

Idea from this tweet by @fermatslibrary

Mathematica graphics

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]]
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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