Permuted Prime Numbers

Question

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} — DavidC, May 31 '15 at 23:02

score 6 · Accepted Answer · answered May 31 '15 at 15:35

6

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

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

answered May 31 '15 at 15:35

rhermans

36,518
4
57
149

Mmm.. I'm late, sorry. But mine avoids the magic numbers "26" and "1229". :) – rhermans May 31 '15 at 15:35
Yes, I suppose there ought to have been a PrimePi[] in there… :) – J. M.'s missing motivation May 31 '15 at 15:50
1

…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. – J. M.'s missing motivation May 31 '15 at 15:54

score 4 · Answer 2 · answered May 31 '15 at 15:28

4

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} *)

answered May 31 '15 at 15:28

Histograms

2,276
12
21

There are no 4 digit primes with this property apparently! – Histograms May 31 '15 at 15:32

score 2 · Answer 3 · answered May 31 '15 at 19:06

2

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)

answered May 31 '15 at 19:06

Theophrastus

121
2

@ Theophrastus : Thanks for the link. – Dr. Wolfgang Hintze Jun 02 '15 at 10:13

ubpdqn · Answer 4 · 2015-06-01T02:35:30.583

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},
  MapThread[
   Length[#1[[1]]] -> 
     Grid[Partition[PadRight[#1, #2^2, ""], #2], 
      Frame -> True] &, {all, s}]]

enter image description here

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.

Permuted Prime Numbers

4 Answers4