Unscrambling jumbled anagrams

I know that we can easily check to see if a string contains any anagrams by the following snippet:

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

Anagrams["listen", 1]
{"enlist", "inlets", "listen", "silent", "tinsel"}

I'm looking to extend Anagrams to partition the given word into n anagrams whose total number of characters is the same as the original string, for example

Anagrams["Dormitory",2]
{"Dirty room" (*among others*)}

What's a simple way to do this, ideally without resorting to combinatorics?

• So for example you would say {"teas, 3} and it would return ate, eat etc.? Your last example is a bit confusing because the number of letters is the same in both strings, just one space vanishes. Anyway, I'm not sure how you would want to do this without using combinatorics at some point. – anderstood Mar 20 '18 at 23:00
• Yes -- good point. I've changed the question to be clearer. I just meant that I could imagine an ugly brute-forcing solution and wondered if there's something inspired and clever that I'm missing. – Landak Mar 20 '18 at 23:09

Edit In this edited version, the upper-case characters are treated as independent characters (you can easily adjust that) and, more importantly, the selection of all the anagrams is more efficient.

An arithmetic-based approach.

Principle The idea is to use primality to check if a word is included in another. For example, if $abc=2\times3\times 5$, then $cb=5\times 3$ divides $abc$ so it is a "sub-anagram". But $aa=2\times 2$ is not because $4$ does not divide $30$. In short, it is based on the unicity of the prime factorization.

Let's go Extract the dictionary (dic) and encode each character with a prime number in an association:

dic = DictionaryLookup["*"];
chars = CharacterRange[65, 300]~Join~{"'", "-"};
corr = <|#[[1]] -> #[[2]] & /@ Transpose[{chars, Prime@Range[Length@chars]}]|>;

Then, convert the dictionary to integers:

convert[s_String] := Times @@ corr /@ Characters[s]
dicnum = convert /@ dic;

As a verification step, we can extract the anagrams of "listen". It is about 150 times faster than the with the code in the OP:

getwords[n_Integer] := dic[[Flatten@Position[dicnum, n]]]
getwords[convert["listen"]]
(* {"enlist", "inlets", "listen", "silent", "tinsel"} *)

Now, let's illustrate the idea with "dormitory": it is converted to an integer, that is then decomposed into a list of all possible products using this answer (thank you @J.M. for pointing it out).

n = convert["dormitory"];
<< Combinatorica`
divisors[x_] := DeleteDuplicates[Sort /@ Map[Times @@ # &,
SetPartitions[Flatten[ConstantArray @@@ FactorInteger[x]]], {2}]]
div = divisors[n]
(* {{37051291718641225291}, {7, 5293041674091603613}, ... *)

div contains the 8155 decompositions of "dormitory". Now, it suffices to pick the ones that correspond to words in the dictionary and recombine them:

good = GatherBy[Select[div, AllTrue[#, MemberQ[dicnum, #] &] &], Length]
recombine[l_] := Flatten@Table[StringRiffle[#, " "] & /@
Distribute[getwords[#] & /@ good[[l, i]], List], {i, Length@good[[l]]}]

Note that the classification by number of words (l) in the anagram is arbitrary.

Results

And now, the fun:

• 1 anagram with one word:

recombine[1]
(* {"dormitory"} *)

• 3 anagrams with two words:

extract[tab, 2]
(* {"moor dirty", "room dirty", "dirt roomy"} *)

• 46 anagrams with three words:

extract[tab, 3]
(* "id try moor", "id try room", "id my rotor", "mi try door", ... *)

• 10 anagrams with four words:

extract[tab, 4]
(* "id om or try", "id or my rot", "id or my tor", "do mi or try", ... *)

And that's it. The method can be easily adapted if you don't want to distinguish ü, û, u, U etc.: just code these letters with the same number. Also, it is exhaustive: all the anagrams are computed.

• A great answer, I really like the idea of using prime numbers to do this. – KraZug Mar 21 '18 at 20:29
• Have you already seen this? – J. M. will be back soon Mar 21 '18 at 23:49

a bit brute force, but not unreasonably slow..

Anagrams[s_String, n_] :=
Module[{min = 1, max, all},(*min sets minimum word length*)
max = StringLength@s - min(n-1);
all = DictionaryLookup[
x__ /; min <= StringLength[x] <= max &&
Complement[Characters[ToLowerCase@x], Characters[s]] == {}];
Select[Subsets[all, {n}],
Sort@Characters[StringJoin @@ (ToLowerCase /@ #)] ==
Sort@Characters[s] &]]
Anagrams["dormitory", 2]

{{"dirt", "roomy"}, {"dirty", "moor"}, {"dirty", "Moor"}, {"dirty", "Moro"}, {"dirty", "room"}}

Anagrams["dormitory", 3]

{{"dim", "or", "Tory"}, {"dim", "or", "troy"}, {"dim", "or", "Troy"},...(210)

incidentally there is only one with 5 words: {{"I", "do", "Mr", "or", "Ty"}}.

• Because you used "dormatory" and not "dormitory"? Could also be that I (arbitrarily) lower-cased the dictionary. – anderstood Mar 21 '18 at 21:04
• @anderstood DOH! yes to both. – george2079 Mar 21 '18 at 21:09
• And that's why I have duplicates: "Moor" becomes "moor", etc. Easy to cope with... – anderstood Mar 21 '18 at 21:10
• after fixing spelling and lower casing the results look the same.. – george2079 Mar 21 '18 at 21:27