2
$\begingroup$

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?

Improve this question
$\endgroup$
5
  • $\begingroup$ Hi there! Have you written the code for S yet? $\endgroup$ Commented Dec 20, 2013 at 13:45
  • $\begingroup$ Is it homework? $\endgroup$ Commented Dec 20, 2013 at 13:49
  • $\begingroup$ yeah in fact it is a homework :$ $\endgroup$ Commented Dec 20, 2013 at 13:55
  • 2
    $\begingroup$ @user116988 In that case, you should use the homework tag. $\endgroup$ Commented Dec 20, 2013 at 13:59
  • 2
    $\begingroup$ What's n? It should be p, right? $\endgroup$ Commented Dec 20, 2013 at 14:07

3 Answers 3

Reset to default
6
$\begingroup$

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] &
Improve this answer
$\endgroup$
6
  • 4
    $\begingroup$ 999 is not a prime $\endgroup$ Commented Dec 20, 2013 at 14:06
  • 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
  • $\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$ @Mr.Wizard it never ceases to amaze me how much I learn from your code and how I over complicate measures...:) $\endgroup$ Commented Apr 19, 2015 at 5:39
1
$\begingroup$ 
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:

enter image description here

Improve this answer
$\endgroup$
1
$\begingroup$

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 *)
Improve this answer
$\endgroup$
4
  • 1
    $\begingroup$ your code does not produce only primes: note-19980,28980,29790,29880, etc $\endgroup$ Commented 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$ Commented 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 be g[f[x]], so my intuition often misleads me here since g[x] can also satisfy the break condition. $\endgroup$ Commented Apr 19, 2015 at 11:24

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.