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

| improve this question | | | | |
$\endgroup$
  • 1
    $\begingroup$ FromDigits[Permutations[IntegerDigits[#]]] & /@ {113, 337, 199} $\endgroup$ – DavidC May 31 '15 at 23:02
  • 1
    $\begingroup$ Hey, I recognize the graphic in your profile picture. :-) $\endgroup$ – Mr.Wizard Jun 1 '15 at 2:44
6
$\begingroup$
Select[
 NestWhileList[NextPrime, 100, # < 9999 &],
 And @@ PrimeQ[FromDigits[Permutations[IntegerDigits[#]]]] &
 ]

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

| improve this answer | | | | |
$\endgroup$
  • $\begingroup$ Mmm.. I'm late, sorry. But mine avoids the magic numbers "26" and "1229". :) $\endgroup$ – rhermans May 31 '15 at 15:35
  • $\begingroup$ Yes, I suppose there ought to have been a PrimePi[] in there… :) $\endgroup$ – J. M.'s technical difficulties May 31 '15 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$ – J. M.'s technical difficulties May 31 '15 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} *)
| improve this answer | | | | |
$\endgroup$
  • $\begingroup$ There are no 4 digit primes with this property apparently! $\endgroup$ – Histograms May 31 '15 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)

| improve this answer | | | | |
$\endgroup$
  • $\begingroup$ @ Theophrastus : Thanks for the link. $\endgroup$ – Dr. Wolfgang Hintze Jun 2 '15 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.

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