Finding primes that have certain property

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?

-
Hi there! Have you written the code for S yet? – cormullion Dec 20 '13 at 13:45
Is it homework? – belisarius has settled Dec 20 '13 at 13:49
yeah in fact it is a homework :\$ – user116988 Dec 20 '13 at 13:55
@user116988 In that case, you should use the homework tag. – becko Dec 20 '13 at 13:59
What's n? It should be p, right? – becko Dec 20 '13 at 14:07

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] &

-
999 is not a prime – becko Dec 20 '13 at 14:06
@becko lol -- well, I couldn't be bothered to read someone else's homework too closely. :o) – Mr.Wizard Dec 20 '13 at 14:07
+1 for demonstration of Composition usage. – Chris Degnen Dec 20 '13 at 14:11
@Chris Thank you. I tried to show several different styles in this short bit of code hoping it would be instructive to work through. – Mr.Wizard Dec 20 '13 at 14:13
@belisarius and Anon; I thought about including additional optimizations but I decided to leave room for improvement for the OP. – Mr.Wizard Dec 20 '13 at 14:43
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:

-

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 *)

-
your code does not produce only primes: note-19980,28980,29790,29880, etc – ubpdqn Apr 19 at 11:08
Oops, it's fixed now. I often forget that Nest-related functions always return the first element. – rhennigan Apr 19 at 11:17
The problem lies in p+1, the necessarily composite p+1 can comply with condition for exiting while – ubpdqn Apr 19 at 11:18
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 be g[f[x]], so my intuition often misleads me here since g[x] can also satisfy the break condition. – rhennigan Apr 19 at 11:24