3
$\begingroup$

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, ...

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

4 Answers 4

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

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

$\endgroup$
3
  • $\begingroup$ Mmm.. I'm late, sorry. But mine avoids the magic numbers "26" and "1229". :) $\endgroup$
    – rhermans
    Commented May 31, 2015 at 15:35
  • $\begingroup$ Yes, I suppose there ought to have been a PrimePi[] in there… :) $\endgroup$ Commented May 31, 2015 at 15:50
  • 1
    $\begingroup$ …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. $\endgroup$ Commented May 31, 2015 at 15:54
4
$\begingroup$

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} *)
$\endgroup$
1
  • $\begingroup$ There are no 4 digit primes with this property apparently! $\endgroup$
    – Histograms
    Commented May 31, 2015 at 15:32
2
$\begingroup$

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)

$\endgroup$
1
  • $\begingroup$ @ Theophrastus : Thanks for the link. $\endgroup$ Commented Jun 2, 2015 at 10:13
2
$\begingroup$

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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