1
$\begingroup$

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]
$\endgroup$
2
$\begingroup$

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}    *)
$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – Jamie M Jun 10 at 18:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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