# Permuted Prime Numbers

How can I produce all 3-digit and 4-digit prime numbers [100-9999] in which, all permutations of all digits produce again a prime number, such as 311, 131, 113, ...

• FromDigits[Permutations[IntegerDigits[#]]] & /@ {113, 337, 199} Commented May 31, 2015 at 23:02
• Hey, I recognize the graphic in your profile picture. :-) Commented Jun 1, 2015 at 2:44

Select[
NestWhileList[NextPrime, 100, # < 9999 &],
And @@ PrimeQ[FromDigits[Permutations[IntegerDigits[#]]]] &
]

{113, 131, 199, 311, 337, 373, 733, 919, 991}

• Mmm.. I'm late, sorry. But mine avoids the magic numbers "26" and "1229". :) Commented May 31, 2015 at 15:35
• Yes, I suppose there ought to have been a PrimePi[] in there… :) Commented May 31, 2015 at 15:50
• …but now that I think about it, you can probably avoid the Select[] and the needless generation of a big list; just combine NestWhileList[] and NestWhile[] appropriately. Commented May 31, 2015 at 15:54

Nice problem. This ought to work:

Select[Table[Prime[i], {i, 26, 1229}],
(And @@ PrimeQ[FromDigits /@ Permutations@IntegerDigits@#]) &]

(* Results {113, 131, 199, 311, 337, 373, 733, 919, 991} *)
• There are no 4 digit primes with this property apparently! Commented May 31, 2015 at 15:32

Here's the relevant online-encyclopedia-(of)-integer-sequences entry (complete with Mathematica and Haskell programs for generation)

Yes indeed, after the three digit permutable primes it seems to go all repunits (that is, all "1"s)

• @ Theophrastus : Thanks for the link. Commented Jun 2, 2015 at 10:13

Just to explore those incomplete sets of permutations of digits:

cand = With[{l = PrimePi[100],
u = PrimePi[10000]},
GatherBy[Prime /@ Range[l + 1, u - 1], Sort[IntegerDigits@#] &]];
fun[n_] := Multinomial @@ Tally[IntegerDigits@n][[All, 2]]
res = SortBy[Select[cand, Length@# > 1 &], Length];
all = GatherBy[
If[fun[#[[1]]] == Length@#, Style[#, Red, Bold] & /@ #, #] & /@
res, Length];
Column@With[{s = Ceiling[Sqrt@#] & /@ Length /@ all},
Length[#1[[1]]] ->
Frame -> True] &, {all, s}]]

To achieve the aim this is relatively quick:

ans = Module[{l = PrimePi[100], u = PrimePi[10000], cand},
cand = GatherBy[Prime /@ Range[l + 1, u - 1],
Sort[IntegerDigits@#] &];
Pick[cand,
Multinomial @@ (Tally[IntegerDigits@#[[1]]][[All, 2]]) ==
Length@# & /@ cand]
]

yielding: {{113, 131, 311}, {199, 919, 991}, {337, 373, 733}}

This avoids repeat testing of permutations.