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$
  • 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}

$\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. will be back soon 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. will be back soon 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} *)
$\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)

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

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