All about flooble | fun stuff | Get a free chatterbox | Free JavaScript | Avatars    
perplexus dot info

Home > Numbers
Odd primes never die (Posted on 2010-05-20) Difficulty: 4 of 5
I 've found an interesting table of numbers in an old issue of JMR, dedicated to astounding trivia regarding primes.
Erasing all the digits in the table's footnotes I got a challenging, albeit solvable puzzle:
The XX consecutive primes from X to XX sum up to the prime number XXX.
Also when arranged in groups of three, each group sums up to a prime number.
Furthermore, those partial sums with their digits reversed, also sum up to the same sum as before the reversal!

Try to reconstruct the trivia : both the table and the text.

No Solution Yet Submitted by Ady TZIDON    
Rating: 3.6667 (3 votes)

Comments: ( Back to comment list | You must be logged in to post comments.)
update | Comment 7 of 11 |
I have modified my original search to now simply count the number of solutions.  My program first created a list of 3 element subsets of the set of 21 primes starting at 7 for which their total is prime.  This found 618 such subsets.  I then systematically search all of the ways to choose 7 of these subsets such that they form a disjoint partition of the original set and where the total of the reverse of the sub-totals is equal to the total of all the original primes.  There are 6,602,055,918,461,784 ways of choosing 7 sets from the 618 so to speed things, each time I pick a new set from the 618 I make sure it does not have any elements in common with the previous sets picked and I also stop the loop when the running total exceeds to original total.  Still this code is going to take quite some time, perhaps several days as I am not able to let it run continuously and must make use of state saves to stop and continue the search at various times.  I am pasting my search code below so if somebody has a fast computer to try running it on perhaps you can get a grand total faster than I can.

prms = Table[Prime[t], {t, 4, 24}];
RevD[x_] := FromDigits[Reverse[IntegerDigits[Total[x]]]];
IsDisj[x_] := 
  If[Length[Flatten[x]] == Length[Union[Flatten[x]]], Return[True], 
   Return[False]];
tot = Total[prms];
cnt = 0;
tups = {};
subs = Subsets[prms, {3}];
For[i = 1, i <= Length[subs], ++i,
  If[PrimeQ[Total[subs[[i]]]],
    cnt++;
    tups = Append[tups, subs[[i]]];
    ];
  ];
ans = 316;
For[i1 = 7, i1 <= cnt - 6, ++i1,
  Print[i1, "/", cnt - 6, " solutions: ", ans];
  set1 = tups[[i1]];
  v1 = RevD[set1];
  For[i2 = i1 + 1, i2 <= cnt - 5, ++i2,
   set2 = tups[[i2]];
   v2 = RevD[set2];
   If[IsDisj[{set1, set2}] && v1 + v2 + 13*5 < tot,
    For[i3 = i2 + 1, i3 <= cnt - 4, ++i3,
      set3 = tups[[i3]];
      v3 = RevD[set3];
      If[IsDisj[{set1, set2, set3}] && v1 + v2 + v3 + 13*4 < tot,
       For[i4 = i3 + 1, i4 <= cnt - 3, ++i4,
         set4 = tups[[i4]];
         v4 = RevD[set4];
         If[
          IsDisj[{set1, set2, set3, set4}] && 
           v1 + v2 + v3 + v4 + 13*3 < tot,
          For[i5 = i4 + 1, i5 <= cnt - 2, ++i5,
            set5 = tups[[i5]];
            v5 = RevD[set5];
            
            If[IsDisj[{set1, set2, set3, set4, set5}] && 
              v1 + v2 + v3 + v4 + v5 + 13*2 < tot,
             For[i6 = i5 + 1, i6 <= cnt - 1, ++i6,
               set6 = tups[[i6]];
               v6 = RevD[set6];
               
               If[IsDisj[{set1, set2, set3, set4, set5, set6}] && 
                 v1 + v2 + v3 + v4 + v5 + v6 + 13 <= tot,
                For[i7 = i6 + 1, i7 <= cnt, ++i7,
                  set7 = tups[[i7]];
                  v7 = RevD[set7];
                  
                  If[IsDisj[{set1, set2, set3, set4, set5, set6, 
                    set7}] && 
                    v1 + v2 + v3 + v4 + v5 + v6 + v7 == Total[prms],
                   ans++;
                   ];];];];];];];];];];];];];


  Posted by Daniel on 2010-05-21 17:54:40
Please log in:
Login:
Password:
Remember me:
Sign up! | Forgot password


Search:
Search body:
Forums (0)
Newest Problems
Random Problem
FAQ | About This Site
Site Statistics
New Comments (3)
Unsolved Problems
Top Rated Problems
This month's top
Most Commented On

Chatterbox:
Copyright © 2002 - 2017 by Animus Pactum Consulting. All rights reserved. Privacy Information