Re: SuperPrimes

*To*: mathgroup at christensen.cybernetics.net*Subject*: [mg632] Re: [mg622] SuperPrimes*From*: villegas (Robert Villegas)*Date*: Mon, 3 Apr 1995 02:14:42 -0500

> Butchering Farmer John's cows always yields the best prime rib. You can > tell prime ribs by looking at the digits lovingly stamped across them, > one by one, by FJ and the USDA. Farmer John ensures that a purchaser of > his prime ribs gets really prime ribs because when sliced from the right, > the numbers on the ribs continue to stay prime right down to the last > rib, e.g.: > > 7 3 3 1 > > The set of ribs 7331 is prime; the three ribs 733 are prime; the two ribs > 73 are prime, and, of course, the last rib, 7, is prime. The number 7331 > is called a superprime of length 4. > > Create a funciton superPrime[N] that accepts a number N of ribs and > prints all the superprimes of that length. > > In[1] superPrime[4] > > Out[1] {2333, 2339, 2393, 2399, 2579, 2939, 3119, 3137, 3733, 3739, > 3793, 3797, 5939, 7193, 7331, 7333, 7393} > > The faster the solution the better. Don, Straight from the definition, a number is superprime if and only if removing the last digit (the ones' digit) leaves a superprime. If you continue removing digits, you find that any superprime has to have a prime first digit. So you can start with the one-digit primes {2, 3, 5, 7} as a basis and build up the superprimes by induction (the induction step uses the fact that any prime of two or more digits has to have an odd last digit). (Basis) Start with superprimes {2, 3, 5, 7}. (Induction) Given any superprime s, the prospective superprimes built from it are s followed by 1, 3, 5, 7, or 9. In Mathematica notation, the list of superprimes built from s are: Select[10 s + {1, 3, 5, 7, 9}, PrimeQ] which can be empty. My induction step is pretty much a brute-force search of possibilities. Maybe some number theory knowledge could be brought to bear on this for a much better overall method. Here's an implementation of this approach: superPrime[n_] := Nest[Flatten[#, 1]& @ Map[Select[10 # + {1, 3, 5, 7, 9}, PrimeQ]&, #] &, {2, 3, 5, 7}, n - 1] In[5]:= superPrime[4] Out[5]= {2333, 2339, 2393, 2399, 2939, 3119, 3137, 3733, 3739, 3793, 3797, > 5939, 7193, 7331, 7333, 7393} Incidentally, the list in Out[5] doesn't have 2579 in it, because 2579 isn't superprime: taking the first two digits gives 25, which isn't prime. It turns out that the number of superprimes of length n increases for a short while and then decreases, finally vanishing at 9: there are no superprimes of length 9. Presumably because primes are getting rarer at larger magnitudes. We can make a list of lists of superprimes up to, say, n = 10 using NestList instead of Nest, and then create a table of lengths: In[7]:= lists = NestList[Flatten[#, 1]& @ Map[Select[10 # + {1, 3, 5, 7, 9}, PrimeQ]&, #] &, {2, 3, 5, 7}, 10 - 1]; In[8]:= Transpose[{Range @ Length[lists], Length /@ lists}] //TableForm Out[8]//TableForm= 1 4 2 9 3 14 4 16 5 15 6 12 7 8 8 5 9 0 10 0 Knowing this, you could add a final rule that would prevent the function from wasting time for n >= 9: superPrime[n_ /; n >= 9] := {} On a tangent, it's possible that a more useful output for the function would be a list of all superprimes of length from 1 to n, instead of just n. At every step, each superprime spawns a set of superprimes with an added digit, for instance 7 spawns two-digit superprimes {71, 73, 79}. We could show that relationship by making a nested list {7, {71, 73, 79}}. This implementation separates out the successor function, which could have been done for the flat list approach, too. In[9]:= nestedSuccessor[list_] := Map[{#, Select[10 # + {1, 3, 5, 7, 9}, PrimeQ]}&, list, {Depth[list] - 1}] In[13]:= nestedSuperPrime[n_] := Nest[nestedSuccessor, {2, 3, 5, 7}, n - 1] In[15]:= nestedSuperPrime[2] Out[15]= {{2, {23, 29}}, {3, {31, 37}}, {5, {53, 59}}, {7, {71, 73, 79}}} We can use 'nestedSuccessor' to compute the complete set of superprimes (given that we know there are no additional ones past a certain point) because we can keep applying it until nothing new is added: In[16]:= complete = FixedPoint[nestedSuccessor, {2, 3, 5, 7}] The output was about a page long, so I deleted it. Robby Villegas P.S. Here's a quick way to, um, peel off the ribs (yuck): ribs[n_] := NestList[Quotient[#, 10]&, n, Floor @ N[Log[10, n]] ] Here are some alternative formulations of the function used in Nest in 'superPrime'. Select[Distribute[{10 #, {1, 3, 5, 7, 9}}, List, List, List, Plus], PrimeQ]& Select[Flatten[#, 1]& @ Outer[Plus, 10 #, {1, 3, 5, 7, 9}], PrimeQ]& Select[Sort @ Flatten[#, 1], PrimeQ]& @ Thread[Unevaluated[10 # + {1, 3, 5, 7, 9}], List, -1] &