0
$\begingroup$

I would like to have Mathematica code for creating the following sequence shown as rows:

row1: 0.

row2: 0.

row3: 0, 0.

row4: 0, 0.

row5: 0, 0 , 0, 0, 0, 0.

row6: -1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, -1, 0, -1, 0, 0, 0, -1, 0, 0, 0, 0, 0, 1, 0.

row7: 2, 0, 0, 0, 0, 0, -2, 0, 0, 0, -2, 0, -2, 0, 0, 0, 2, 0, 2, 0, 0, 0, 2, 0, 0, 0, 0, 0, -2, 0.

Row lengths are given by https://oeis.org/A058250.

Example for calculating row 6 values:

For the primorial number 2*3*5*7*11 = 2310, which has 480 totatives (480 coprimes of 2310 < 2310), the specified ranges are given by 480/2310. 480/2310 as the reduced fraction 16/77. Creating a set of GCD (2310,480) = 30 fractions by adding 16 and 77 respectively to the numerator and denominator of the reduced fraction 16/77 gives the 30 fractions (only 9 shown):

16/77, 32/154, 48/231, 64/308, 80/385, 96/462, 112/539, ... 464/2233, 80/2310. 

Finding the totatives of 2310 which are smaller and nearest to each of the 30 denominators (only 9 shown):

77, 154, 231, 308, 385, 462, 539, ..., 2233, 2310. 

gives the 30 totatives (only 9 shown):

73, 151, 229, 307, 383, 461, 533, ..., 2231, 2309.

In the list of 480 totatives of 2310, these values are the 17th, 32nd, 48th, 64th,80th, 96th, 111th, ..., 463th, 480th totatives of 2310. That is, 73 is the 17th totative of 2310, counting from 1 which is the first totative of 2310.

To generate row6 values from this, subtract the numerator of the 30 fractions from these values (only 9 shown):

(16-17), (32-32), (48-48), (64-64), (80-80), (96-96), (112-111),..., (464-463), (480-480).

The full 30 values of row 6:

-1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, -1, 0, -1, 0, 0, 0, -1, 0, 0, 0, 0, 0, 1, 0.

Also interested in the row sums and the non-zero value locations on rows, i.e., sum of values on a row = 0 always I think. Non-zero value positions on row 6 and row 7 are: 1, 7, 11, 13, 17, 19, 23, 29.

For row 5, use the primorial number 2*3*5*7 = 210, which has 48 totatives (48 coprimes of 210 < 210). Creating a set of GCD(210,48) = 6 fractions by adding 8 and 35 respectively to the numerator and denominator of the reduced fraction 8/35 gives:

8/35, 16/70, 24/105, 32/140, 40/175, 48/210. 

Finding the totatives of 210 which are smaller and nearest to each of the denominators:

35,70,105,140,175,210. 

gives the totatives:

31,67,103,139,173,209.  Thanks.

For row 7, use the primorial number 2*3*5*7*11*13 = 30030, which has 5760 totatives (5760 coprimes of 30030 < 30030). Then create a set of GCD(30030, 5760) = 30 fractions, given by https://oeis.org/A058250.

$\endgroup$

closed as off-topic by ciao, m_goldberg, Carl Lange, MarcoB, Roman May 8 at 7:13

  • The question does not concern the technical computing software Mathematica by Wolfram Research. Please see the help center to find out about the topics that can be asked here.
If this question can be reworded to fit the rules in the help center, please edit the question.

  • 2
    $\begingroup$ I'm voting to close this question as off-topic because there is zero effort shown: this is not a mechanical turk site. $\endgroup$ – ciao May 6 at 19:28
  • 4
    $\begingroup$ I'm voting to close this question as off-topic because there is no well-posed question in this post; the OP is simply asking for somebody to act as a free coding service. $\endgroup$ – m_goldberg May 6 at 23:06
3
$\begingroup$

UPDATE 1:

I've changed two parts: the totatives and nearest calculations. The code seems to be about 10x faster now, and doesn't consume nearly as much memory. It's still probably not the most elegant code, though.

calc[row_] := 
 Block[{primorial, length, fracs, totatives, nearest, goal}, 
  If[row == 1, Return[{0}]];
  primorial = Times @@ Prime[Range[row - 1]];
  length = GCD[primorial, EulerPhi[primorial]];
  fracs = {Numerator[#], Denominator[#]} &[
       EulerPhi[primorial]/primorial] # & /@ Range[length];
  totatives = Reap[
     Do[
      If[CoprimeQ[primorial, i], Sow[i]],
      {i, primorial - 1}
      ]
     ][[2, 1]];
  goal = 1;
  nearest = Reap[
     Do[
      If[totatives[[i]] >= fracs[[goal, 2]], Sow[i - 1]; goal++],
      {i, Length[totatives]}
      ];
     Sow[Length[totatives]]
     ][[2, 1]];
  fracs[[All, 1]] - Flatten[nearest]]

The output of calc[10] (the row with 330 values) is:

{0,4,2,0,0,-5,-1,-3,-4,-4,0,-1,2,-1,0,-1,1,-1,2,0,1,0,2,0,-3,-1,-2,-3,1,0,0,4,0,-1,-1,-3,-1,-2,-5,4,0,-4,4,0,0,-2,0,3,0,3,4,6,1,8,0,1,-6,-1,-1,0,-5,2,1,0,-3,0,0,-2,-2,4,1,1,1,-2,0,-3,0,5,1,-3,7,5,5,9,-3,0,1,0,-1,0,-1,3,2,3,1,-4,-1,0,0,-4,-1,-4,2,-1,0,-1,-1,-2,2,0,2,0,1,5,0,0,1,1,-1,0,0,5,3,5,1,-4,-3,-2,-1,0,-2,0,3,2,0,0,-1,0,0,-3,1,1,0,4,1,-1,-2,-1,2,0,-2,2,0,0,-3,-6,-1,-3,-5,-3,-1,-3,3,3,0,-3,-3,3,1,3,5,3,1,6,3,0,0,-2,2,0,-2,1,2,1,-1,-4,0,-1,-1,3,0,0,1,0,0,-2,-3,0,2,0,1,2,3,4,-1,-5,-3,-5,0,0,1,-1,-1,0,0,-5,-1,0,-2,0,-2,2,1,1,0,1,-2,4,1,4,0,0,1,4,-1,-3,-2,-3,1,0,1,0,-1,0,3,-9,-5,-5,-7,3,-1,-5,0,3,0,2,-1,-1,-1,-4,2,2,0,0,3,0,-1,-2,5,0,1,1,6,-1,0,-8,-1,-6,-4,-3,0,-3,0,2,0,0,-4,4,0,-4,5,2,1,3,1,1,0,-4,0,0,-1,3,2,1,3,0,-2,0,-1,0,-2,1,-1,1,0,1,-2,1,0,4,4,3,1,5,0,0,-2,-4,0,0}

ORIGINAL:

Here is my attempt. It runs slightly faster, but the calculation time increases pretty rapidly beyond 7. The 9th row took 82 seconds on my machine. There are probably faster algorithms out there.

calc[row_] := Block[{primorial, length, fracs, totatives, nearest},
  If[row == 1, Return[{0}]];
  primorial = Times @@ Prime[Range[row - 1]];
  length = GCD[primorial, EulerPhi[primorial]];
  fracs = {Numerator[#], Denominator[#]} &[
  EulerPhi[primorial]/primorial] # & /@ Range[length];
  totatives = 
   Pick[#, CoprimeQ[primorial, #], True] &[Range[primorial - 1]];
  nearest = 
   Nearest[totatives -> "Index", fracs[[All, 2]], 
    DistanceFunction -> (If[#1 < #2, $MaxNumber, Norm[#1 - #2]] &)];
  fracs[[All, 1]] - Flatten[nearest]
 ]
$\endgroup$
  • $\begingroup$ Thanks, how do I call that code? I tried calc[3] but didn't work. $\endgroup$ – Jamie M May 6 at 4:24
  • $\begingroup$ @JamieM That's odd, it seems to work for me. calc[3] outputs {0, 0} for me. Do you get any output at all? $\endgroup$ – MassDefect May 6 at 4:59
  • $\begingroup$ Part::partw: Part 2 of NumeratorDenominator[1/3] does not exist. $\endgroup$ – Jamie M May 6 at 5:05
  • $\begingroup$ I get some errors, Nearest::nearuf: The user-supplied distance function If[#1<#2,$MaxNumber,Norm[#1-#2]]& does not give a real numeric distance when applied to the point pair {NumeratorDenominator[1/3],2 NumeratorDenominator[1/3]}[[All,2]] and 1. $\endgroup$ – Jamie M May 6 at 5:06
  • 1
    $\begingroup$ @JamieM I've updated the code and it's faster now, though the timing still grows pretty rapidly. Do you have any way to verify the results? I've shown the output of row 10, and I don't get all zeroes, though I do get all zeroes for rows 1-5, 8, and 9. I think the code is correct, but it'd be nice to verify it. The new code agrees with the old code for rows 1 - 9, but 10 takes too long to run on the old code. $\endgroup$ – MassDefect May 8 at 6:07
4
$\begingroup$

Try

run[row_] := Block[{}, 
     var1 = (Times @@ ##1 & )[(Prime[#1] & ) /@ Range[1, row - 1]]; 
      var2 = Length[(Prime[#1] & ) /@ Range[1, var1]]; 
      var3 = Total[(Boole[#1] & )[(CoprimeQ[var1, #1] & ) /@ 
              Range[1, var1]]]; var4 = GCD[var2, var3]; 
  var5 = var3/var2; 
      var6 = Flatten[Thread[{Range[1, var4]}*Numerator[var5]]]; 
      var7 = Flatten[Thread[{Range[1, var4]}*Denominator[var5]]]; 
      func3[var_, x_] := 
   Last[(If[CoprimeQ[var, #1], #1, Nothing] & ) /@ 
            Range[1, x]]; var8 = (func3[var1, #1] & ) /@ var7; 
      func4[var_, x_] := (Flatten[Position[Flatten[#1], x]] & )[
          (If[CoprimeQ[var, #1], #1, Nothing] & ) /@ Range[1, var]]; 
      var9 = (func4[var1, #1] & ) /@ var8; var6 - Flatten[var9]]
run /@ Range[1, 7]; 
Grid[%, Frame -> All]

enter image description here

$\endgroup$

Not the answer you're looking for? Browse other questions tagged or ask your own question.