Let S[p] denote the sum of digits of p. A prime p is said to be stubborn if none of S[n] + 1, S[n], S[n] - 1, S[n] - 2 , or S[n] - 3 is a prime. Write a Mathematica code that finds the smallest stubborn prime and tell which prime is it?
$\begingroup$
$\endgroup$
5
3 Answers
$\begingroup$
$\endgroup$
7
Here is a direct approach:
digitsum = Composition[Total, IntegerDigits];
stubbornQ = PrimeQ[#] && Nor @@ PrimeQ[digitsum[#] - {1, 2, 3, 0, -1}] &;
i = 1;
While[! stubbornQ[++i]]
i
8999
This was quite sufficient in this case. For larger search spaces see Iterate until condition is met.
A bit more efficient for v10+ using NoneTrue for early exit:
stubbornQ = PrimeQ[#] && NoneTrue[digitsum[#] - {1, 2, 3, 0, -1}, PrimeQ] &
answered Dec 20, 2013 at 14:01
-
4
-
1$\begingroup$ @becko lol -- well, I couldn't be bothered to read someone else's homework too closely. :o) $\endgroup$ Commented Dec 20, 2013 at 14:07
-
2$\begingroup$ +1 for demonstration of
Compositionusage. $\endgroup$ Commented Dec 20, 2013 at 14:11 -
$\begingroup$ @Chris Thank you. I tried to show several different styles in this short bit of code hoping it would be instructive to work through. $\endgroup$ Commented Dec 20, 2013 at 14:13
-
1$\begingroup$ @belisarius and Anon; I thought about including additional optimizations but I decided to leave room for improvement for the OP. $\endgroup$ Commented Dec 20, 2013 at 14:43
$\begingroup$
$\endgroup$
j = 1;
While[
Or @@ (PrimeQ@({#-3,# - 2, # - 1, #, # + 1} &@(Total@
IntegerDigits[Prime[j]]))), j++]
Prime[j]
So 8999 has desired property:
{#-3,# - 2, # - 1, #, # + 1} &@(Total@IntegerDigits[Prime[1117]]))
yields:{32, 33, 34, 35, 36}
for fun:
query[u_] :=
Nor @@ PrimeQ[# + {-3, -2, -1, 0, 1} &@Total[IntegerDigits@u]]
cand = Prime[#] & /@ Range[1000, 10000]; Grid[
Partition[PadRight[Pick[cand, query /@ cand], 168, ""], 12]]
The first 167 stubborn primes:
$\begingroup$
$\endgroup$
4
Here's a functional approach without using loops:
st[p_] := PrimeQ[Total @ IntegerDigits @ p + Range[-3, 1]] ~ AllTrue ~ Not // Not
nextStubborn[p_] := NestWhile[NextPrime, NextPrime[p], st]
stubbornList[n_] := NestList[nextStubborn, 2, n] // Rest
stubbornList[100]
(* {8999, 18899, 19889, 19979, 19997, 28979, 29789, 29879, 35999, 36899, *)
(* 37799, 37889, 37997, 38699, 39779, 39869, 39887, 45989, 46889, 46997, *)
(* 47699, 47969, 48779, 48869, 49499, 49697, 49787, 49877, 55799, 55889, *)
(* 55997, 56897, 57689, 57977, 58679, 58787, 58967, 59399, 59669, 59957, *)
(* 64997, 65699, 65789, 66797, 66959, 66977, 67499, 67589, 67679, 67967, *)
(* 68399, 68489, 68597, 68669, 68687, 68777, 68993, 69389, 69497, 69677, *)
(* 69767, 69857, 69929, 71999, 74699, 74897, 75689, 75797, 75869, 76679, *)
(* 76697, 76949, 77489, 77687, 77849, 77867, 78479, 78497, 78569, 78839, *)
(* 78857, 78893, 78929, 79379, 79397, 79559, 79757, 79829, 79847, 79973} *)
To just get the smallest:
nextStubborn[1]
(* 8999 *)
-
1$\begingroup$ your code does not produce only primes: note-19980,28980,29790,29880, etc $\endgroup$– ubpdqnCommented Apr 19, 2015 at 11:08
-
$\begingroup$ Oops, it's fixed now. I often forget that Nest-related functions always return the first element. $\endgroup$ Commented Apr 19, 2015 at 11:17
-
$\begingroup$ The problem lies in
p+1, the necessarily composite p+1 can comply with condition for exiting while $\endgroup$– ubpdqnCommented Apr 19, 2015 at 11:18 -
$\begingroup$ Right, that is what I meant. I should say that "I forget that the function applied zero times is included". My intuition for these things is that the first element to check a condition for in
NestWhile[f, x, g]would beg[f[x]], so my intuition often misleads me here sinceg[x]can also satisfy the break condition. $\endgroup$ Commented Apr 19, 2015 at 11:24
Syet? $\endgroup$homeworktag. $\endgroup$n? It should bep, right? $\endgroup$