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