Finding the value which gives a list total of zero

Question

Is there a way to check if x will converge for Total[g] approaching zero in this code example? For n=15000000, 1.87 < x < 1.88, but takes awhile to run. Thanks.

cheers, Jamie

n = 500000;
a = Select[Range[n], FactorInteger[#][[1, 1]] >= 5 && ! PrimeQ[#] &];
x = 2;
b = Differences[a];
c = Range[x, Length[a]*x, x];
d = c - a;
AppendTo[b, 0];
e = c - b;
f = Abs[d] - Abs[e];
g = Drop[f, -1];
Total[g]

Roman · Accepted Answer · 2019-06-10T19:25:11.277

This is about ten times faster by starting with a list that does not contain any multiples of 2 and 3, so that the smallest integer factor is guaranteed to be at least 5 by construction. Thus we only need to check for primality and can leave away the integer factorization:

F[n_Integer?Positive, x_?NumericQ] := Module[{a, c},
  a = Select[Union[Range[5, n, 6], Range[7, n, 6]], ! PrimeQ[#] &];
  c = x*Range[Length[a]];
  Total[Most[Abs[c - a]]] - Total[Abs[Most[c] - Differences[a]]]]

We gain another huge factor by noticing that the list a depends only on n, not on x, and can be reused between calls:

alist[n_Integer?Positive] := alist[n] = 
  Select[Union[Range[7, n, 6], Range[5, n, 6]], ! PrimeQ[#] &];
F[n_Integer?Positive, x_?NumericQ] := Module[{a, c},
  a = alist[n];
  c = x*Range[Length[a]];
  Total[Most[Abs[c - a]]] - Total[Abs[Most[c] - Differences[a]]]]

FindRoot[F[15000000, x] == 0, {x, 2}]
(*    {x -> 1.877}    *)

Use higher working precision in order to get a more accurate result:

FindRoot[F[15000000, x] == 0, {x, 2}, WorkingPrecision -> 50]
(*    {x -> 1.8770030863174339272847074995530758016555733942289}    *)

update: more general case

If we want to be able to choose the smallest prime factor $p$, we modify the alist function:

Clear[alist];
alist[p_?PrimeQ, n_Integer?Positive] := alist[p, n] = Module[{L, P, A},
  (* compute the repeating pattern *)
  P = Select[Range[p - 1], PrimeQ];
  L = Times @@ P;
  A = Fold[Select[#1, Function[z, ! Divisible[z, #2]]] &, Range[0, L - 1], P];
  (* repeat this pattern up to n *)
  Select[Join @@ (A + # & /@ Range[0, Floor[n - 1, L], L]), 
    p <= # <= n && ! PrimeQ[#] &]]

The function now takes an extra parameter p that is the smallest prime factor:

F[p_?PrimeQ, n_Integer?Positive, x_?NumericQ] := Module[{a, c},
  a = alist[p, n];
  c = x*Range[Length[a]];
  Total[Most[Abs[c - a]]] - Total[Abs[Most[c] - Differences[a]]]]

test:

FindRoot[F[2, 1000000, x] == 0, {x, 2}]
(*    {x -> 0.544595}    *)

FindRoot[F[3, 1000000, x] == 0, {x, 2}]
(*    {x -> 1.1958}    *)

FindRoot[F[5, 1000000, x] == 0, {x, 2}]
(*    {x -> 1.9882}    *)

FindRoot[F[7, 1000000, x] == 0, {x, 2}]
(*    {x -> 2.70512}    *)

FindRoot[F[11, 1000000, x] == 0, {x, 2}]
(*    {x -> 3.40701}    *)

FindRoot[F[13, 1000000, x] == 0, {x, 2}]
(*    {x -> 3.96854}    *)

FindRoot[F[17, 1000000, x] == 0, {x, 2}]
(*    {x -> 4.5446}    *)

FindRoot[F[19, 1000000, x] == 0, {x, 2}]
(*    {x -> 5.06328}    *)

Thanks I tested it to n=100000000, x=1.8251, and for n=200000000 x=1.80954. Not sure if that will converge, but seems unlikely. For the larger n FindRoot gave a machinePrecision digits error on 64bit OS, ignoring that I also ran into system memory error. I would like to do the same for the list of composites with least prime factor p, ie instead of FactorInteger[#][[1, 1]] >= 5, it would be >=p for 2,3,5,7,11,.. and check the value of x in each case. Also since the larger p lists have sparse composites, it would be good to have the same list length for all p when calculating the x values. — Jamie M, Jun 10 '19 at 18:38

Finding the value which gives a list total of zero

1 Answers1

update: more general case