Mathematica [Mathematica] How many circular primes below 1E+6

[martix]

Circular meaning all of its digit rotations are also prime.

PrimeLimit = 1000000;
NoRotate = Select[Range[PrimeLimit], PrimeQ];

Rotate1 = 
  Select[FromDigits[#] & /@ (RotateLeft[IntegerDigits[#]] & /@ 
      Select[Range[PrimeLimit], PrimeQ]), PrimeQ];

Rotate2 = 
  Select[FromDigits[#] & /@ (RotateLeft[
        RotateLeft[IntegerDigits[#]]] & /@ 
      Select[Range[PrimeLimit], PrimeQ]), PrimeQ];

Rotate3 = 
  Select[FromDigits[#] & /@ (RotateLeft[
        RotateLeft[RotateLeft[IntegerDigits[#]]]] & /@ 
      Select[Range[PrimeLimit], PrimeQ]), PrimeQ];

Rotate4 = 
  Select[FromDigits[#] & /@ (RotateLeft[
        RotateLeft[RotateLeft[RotateLeft[IntegerDigits[#]]]]] & /@ 
      Select[Range[PrimeLimit], PrimeQ]), PrimeQ];

Rotate5 = 
  Select[FromDigits[#] & /@ (RotateLeft[
        RotateLeft[
         RotateLeft[RotateLeft[RotateLeft[IntegerDigits[#]]]]]] & /@ 
      Select[Range[PrimeLimit], PrimeQ]), PrimeQ];

Count[Intersection[NoRotate, Rotate1, Rotate2, Rotate3, Rotate4, 
  Rotate5], _Integer]

Tried with this... Apparently I am wrong.
I know it's ugly, but for the extent I'm familiar with mathematica, this was the fastest to write.

3 Relevant questions:
Why am I wrong?
How can I make it right?
How can I make it more streamlined/efficient/non-spaghettized?

Edit: Additional tinkering:

PrimeLimit = 1000000;
PrimeList = Select[Range[PrimeLimit], PrimeQ];

For[i = 0, i < 5, i++, 
  PrimeList = 
   Intersection[PrimeList, 
    Select[FromDigits[#] & /@ (RotateLeft[IntegerDigits[#]] & /@ 
        PrimeList), PrimeQ]]];

This also fails :(

 

[Bill Simpson]

To diagnose this let's look at the result, not just the count.

In[1]:= PrimeLimit=1000000;
NoRotate=Select[Range[PrimeLimit],PrimeQ];
Rotate1=Select[FromDigits[#]&/@(RotateLeft[IntegerDigits[#]]&/@Select[Range[PrimeLimit],PrimeQ]),PrimeQ];
Rotate2=Select[FromDigits[#]&/@(RotateLeft[RotateLeft[IntegerDigits[#]]]&/@Select[Range[PrimeLimit],PrimeQ]),PrimeQ];
Rotate3=Select[FromDigits[#]&/@(RotateLeft[RotateLeft[RotateLeft[IntegerDigits[#]]]]&/@Select[Range[PrimeLimit],PrimeQ]),PrimeQ];
Rotate4=Select[FromDigits[#]&/@(RotateLeft[RotateLeft[RotateLeft[RotateLeft[IntegerDigits[#]]]]]&/@Select[Range[PrimeLimit],PrimeQ]),PrimeQ];
Rotate5=Select[FromDigits[#]&/@(RotateLeft[RotateLeft[RotateLeft[RotateLeft[RotateLeft[IntegerDigits[#]]]]]]&/@Select[Range[PrimeLimit],PrimeQ]),PrimeQ];
result=Intersection[NoRotate,Rotate1,Rotate2,Rotate3,Rotate4,Rotate5]

Out[8]=
{2,3,5,7,11,13,17,31,37,71,73,79,97,113,131,197,199,311,337,373,397,719,733,\
911,919,971,991,1193,1777,1931,3119,3191,3313,3719,3733,3779,7393,7793,7937,\
9311,9377,9791,11131,11177,11939,13337,17713,17791,19391,19717,19793,19937,\
19991,31771,31799,33119,33713,33911,33937,37199,39119,39199,39791,39971,71119,\
71191,71317,71399,71711,71971,71993,71999,73133,79139,79397,79973,91193,93113,\
93719,93911,93979,93997,97373,97919,99119,99137,99371,99713,99971,193939,\
199933,319993,331999,391939,393919,919393,933199,939193,939391,993319,999331}

NOTE: Use caution if you scrape this off the screen and paste it into Mathematica. Somewhere between scraping this out of Mathematica and pasting into the forum is inserting spaces between some digits. I've seen this before and never been able to track down the cause.

Now notice that 397 is in your result, but one of the left rotations is not prime.

In[9]:= {PrimeQ[397],PrimeQ[973],PrimeQ[739]}
Out[9]= {True,False,True}

Now you have a single specific example in your result that, if I have not made a mistake, should not be there. Does that give you something specific enough to track down the error?

Now since you asked for more efficient code here are two iterations.

In[58]:= PrimeLimit=1000000;
primes=Select[Range[PrimeLimit],PrimeQ];
NoRotate=Select[Range[PrimeLimit],PrimeQ];
Rotate1=Select[primes,PrimeQ[FromDigits[RotateLeft[IntegerDigits[#],1]]]&];
Rotate2=Select[primes,PrimeQ[FromDigits[RotateLeft[IntegerDigits[#],2]]]&];
Rotate3=Select[primes,PrimeQ[FromDigits[RotateLeft[IntegerDigits[#],3]]]&];
Rotate4=Select[primes,PrimeQ[FromDigits[RotateLeft[IntegerDigits[#],4]]]&];
Rotate5=Select[primes,PrimeQ[FromDigits[RotateLeft[IntegerDigits[#],5]]]&];
Intersection[NoRotate,Rotate1,Rotate2,Rotate3,Rotate4,Rotate5]

Out[66]={2,3,5,7,11,13,17,31,37,71,73,79,97,113,131,197,199,311,337,373,719,733,919,\
971,991,1193,1931,3119,3779,7793,7937,9311,9377,11939,19391,19937,37199,39119,\
71993,91193,93719,93911,99371,193939,199933,319993,331999,391939,393919,\
919393,933199,939193,939391,993319,999331}

And

In[74]:= PrimeLimit=1000000;
primes=Select[Range[PrimeLimit],PrimeQ];
Intersection@@Table[Select[primes,PrimeQ[FromDigits[RotateLeft[IntegerDigits[#],i]]]&],{i, 0,5}]

Out[76]= {2,3,5,7,11,13,17,31,37,71,73,79,97,113,131,197,199,311,337,373,719,733,919,\
971,991,1193,1931,3119,3779,7793,7937,9311,9377,11939,19391,19937,37199,39119,\
71993,91193,93719,93911,99371,193939,199933,319993,331999,391939,393919,\
919393,933199,939193,939391,993319,999331}

 

[martix]

So basically it checks only against the general prime list, not any of it's rotations, which allows numbers with non-prime rotations to slip by, as long as they are prime themselves.

Something which I sort of fixed in my edited code which intersects recursively. Only just today did it occur to me it should run 6 iterations, not 5(max of 6 digits and all) :)

Got the same result as you. Mine is also faster than yours.
(Just discovered how to time execution in Mathematica: "//Timing". As for numerical values(yours vs mine) - 6.047 vs 1.594.)

Missed the fact that RotateLeft can take also a RotateBy argument. And forgot about Tables.
Eh well... that's the purpose of these problems anyway(learn Mathematica).

 

[Bill Simpson]

I'm puzzled by your conclusion that "it checks only against the general prime list, not any of it's rotations."

Your original code is eliminating many many primes that have a non-prime rotation. So it doesn't seem to be ignoring all the rotations, but it is missing some. Determining exactly why might be a learning experience.

Next I am concerned by your realization that you need to run 6 iterations because you have 6 digits.

Doesn't rotating a 6 element list by 6 just give you back the original unrotated list?

Precision and correctness, those are key.

I agree completely with you that the purpose is to learn.

 

[martix]

Well if I rotate 5 times, I miss on one intersection pair when there 6 digits - the one between the original set and the last rotated set. It covers all 6 pairs of sets with 5 iterations, but not all adjacent set pairs for that direction.

As for the original algorithm - I see your point. As for why... I'm not exactly sure. It's not the most readable of code I have produced.

I've been looking at it for some time now and considering I came up with something better in every regard eventually, my motivation for finding the error in the original algorithm is sort of fading.

On a related note(optional as far as participation by anyone else goes):
I solved another problem: Find the first four consecutive integers to have four different primes factors. What is the first of these numbers?

FactorCount = 4;
ConsecutivePrimeCount = 4;
i = 10;
(While [! (Table[
        Length[FactorInteger[#]] &[j], {j, i, 
         i + (ConsecutivePrimeCount - 1)}] == 
       Table[FactorCount, {ConsecutivePrimeCount}]), i++]
   i) // Timing

Looking for more speed.
It is pretty fast now, but it can probably be faster, question being how?

 

[Bill Simpson]

Speed up your original program using two ideas, but without making it too much more complicated.

PrimeLimit=1000000;
PrimeList=Map[IntegerDigits,Select[Range[PrimeLimit],PrimeQ]];
PrimeList=Cases[PrimeList,{(1|3|7|9)..}];
For[i=1,i<6,i++,PrimeList=Select[PrimeList,PrimeQ[FromDigits[RotateLeft[#,i]]]&]];
PrimeList=Join[{2,5},Map[FromDigits,PrimeList]]

Challenges:
Find a substitute for the For that doesn't slow this down.
Find a way to RotateLeft by a single digit only on each pass that doesn't slow this down.