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, ...
4 Answers
Select[
NestWhileList[NextPrime, 100, # < 9999 &],
And @@ PrimeQ[FromDigits[Permutations[IntegerDigits[#]]]] &
]
{113, 131, 199, 311, 337, 373, 733, 919, 991}
-
$\begingroup$ Mmm.. I'm late, sorry. But mine avoids the magic numbers "26" and "1229". :) $\endgroup$– rhermansCommented 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 combineNestWhileList[]
andNestWhile[]
appropriately. $\endgroup$ 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} *)
-
$\begingroup$ There are no 4 digit primes with this property apparently! $\endgroup$ 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)
-
$\begingroup$ @ Theophrastus : Thanks for the link. $\endgroup$ 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},
MapThread[
Length[#1[[1]]] ->
Grid[Partition[PadRight[#1, #2^2, ""], #2],
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.
FromDigits[Permutations[IntegerDigits[#]]] & /@ {113, 337, 199}
$\endgroup$