Message Boards Message Boards

Proof algorithm for composite cases of A269254

Posted 6 years ago

On seqfans we have been calculating like crazy, trying to figure out the logic behind sequence A269254, Original Post, Proof Example.

After much discussion, we suggest the following unproven but probable premises:

  • All composite sequences correspond to non-prime values $n = 2 T_m(k/2), k > 2, m > 1 \in $ primes, where $T_n$ is ChebyshevT, From Andrew Hone.
  • The composite sequence $s_k$ defined by A269254 admits an m-section $XY_{k}=s_{m*k+o}$ into $m$ subsequences indexed by $o$.
  • Each of the $m$ subsequences admits factorization $XY_{k} = X_{k}*Y_{k}$.
  • $XY$, $X$, and $Y$ satisfy the same linear recurrences regardless of $o$ .
  • The linear recurrences for $XY$ and $X$ both involve three terms, while the linear recurrence for $Y$ involves $m+1$ terms.
  • The signature of the $X$ recurrence is $(n,-1)$.

If we accept these premises as true, then we can write an algorithm for proving a sequence $s_k$ entirely composite on a case-by-case basis, and look through all cases beneath a certain cutoff, say $N=10,000$. The proof algorithm is a generalization of: Case 110.

Proof Algorithm

Input: Indexes $n$ and $m$ for a sequence satisfying the above criteria.

Output: A list of proof results: True if the initial conditions of XY contain no primes, True if X strictly increases over initial conditions, True if condition four above is met, signatures of the linear recurrences, a sum which equals zero when the induction base case is satisfied, a zero-sum that indicates the induction hypothesis admits recursion.

Recurrence[n_, m_] := 
 LinearRecurrence[{n, -1}, {1, n + 1}, m*(2 m + 1)]

RecurrenceFactorsX[n_, m_, rec_] := Map[Function[{o}, Select[
     Flatten[
      Outer[LinearRecurrence[{n, -1}, {#1, #2}, 2 m + 1] &, 
       Sequence @@ (Divisors /@ rec[[m*Range[2] - o]]), 1], 1], 
     And @@ Map[IntegerQ, rec[[m*Range[2 m + 1] - o]]/#] &][[1]]],
  Range[0, m - 1]]

RecurrenceFactorsY[n_, m_, rec_, recX_] := MapThread[
  Divide,
  {rec[[m*Range[2 m + 1] - #]] & /@ Range[0, m - 1], recX}]

FactorMap[m_, recX_, recY_] := {
  X[k] -> Total[
    MapThread[Times, {Part[FindLinearRecurrence /@ recX, 1],
      X[k - #] & /@ Range[2]}]],
  Y[k] -> Total[
    MapThread[Times, {Part[FindLinearRecurrence /@ recY, 1],
      Y[k - #] & /@ Range[m]}]]}

ZeroSum[n_, 0, map_, recXY_] := 
 Expand[s[k] - FindLinearRecurrence[recXY[[1]]][[1]] s[k - 1] + 
     s[k - 2] /. {s[z_] :> X[z] Y[z]} /. map]
ZeroSum[n_, r_, map_, recXY_] := 
 Expand[ZeroSum[n, r - 1, map, recXY] /. k -> k + 1 /. map]

BasisVectors[m_] := 
 Flatten@Outer[Times, X[k - #] & /@ Range[2], Y[k - #] & /@ Range[m]]

InductionBaseCase[n_, m_, recX_, recY_, recXY_] := 
 Total[Total[Abs[ReplaceAll[ZeroSum[
          n, #, FactorMap[m, recX, recY], recXY] & /@ 
        Range[0, m - 1], {
        X[z_] :> recX[[#, z /. k -> m + 1]],
        Y[z_] :> recY[[#, z /. k -> m + 1]]
        }] & /@ Range[m]]]]

InductionZeroSum[n_, m_, recX_, recY_, recXY_] := ReplaceAll[
  0 == Dot[v /@ Range[0, m - 1], c /@ Range[0, m - 1] /. c[0] -> 1],
  Solve[Dot[
      ReplaceAll[c /@ Range[0, m - 1], c[0] -> 1],
      Outer[Coefficient,
       ZeroSum[n, #, FactorMap[m, recX, recY], recXY] & /@ 
        Range[0, m - 1],
       BasisVectors[m]
       ]] == 0, c /@ Range[m - 1]][[1]]]

A269254CompositeQ[n_, m_] := Module[
  {rec, recX, recY, recXY, signatures},
  rec = Recurrence[n, m];
  recX = RecurrenceFactorsX[n, m, rec];
  recY = RecurrenceFactorsY[n, m, rec, recX];
  recXY = MapThread[Times, {recX, recY}];
  signatures = MapThread[Rule,
    {{XY, X, Y}, 
     FindLinearRecurrence /@ {recXY[[1]], recX[[1]], recY[[1]]}}];
  Flatten@{
    And @@ (! PrimeQ[#] & /@ rec),
    And @@ Map[And @@ (Less @@ # & /@ Partition[#, 2, 1]) &, recX],
    And[SameQ[FindLinearRecurrence /@ recX],
     SameQ[FindLinearRecurrence /@ recY],
     SameQ[FindLinearRecurrence /@ recXY]],
    signatures,
    InductionBaseCase[n, m, recX, recY, recXY],
    InductionZeroSum[n, m, recX, recY, recXY]}
  ]

Return

 TwoList =  Select[Expand[2 ChebyshevT[2, k/2]] /. k -> Range[2, 100], 
  2 < # < 10000 &]
ThreeList = Select[Expand[2 ChebyshevT[3, k/2]] /. k -> Range[2, 50], 
  2 < # < 10000 &]
FiveList =  Select[Expand[2 ChebyshevT[5, k/2]] /. k -> Range[1, 25], 
  2 < # < 10000 &]
SevenList = Select[Expand[2 ChebyshevT[7, k/2]] /. k -> Range[1, 20], 
  2 < # < 10000 &]

2 ChebyshevT[11, 3/2]
Out[] = 39603

AbsoluteTiming[ Tab2 = A269254CompositeQ[#, 2] & /@ TwoList // TableForm;]
AbsoluteTiming[Tab3 = A269254CompositeQ[#, 3] & /@ ThreeList // TableForm;]
AbsoluteTiming[Tab5 = A269254CompositeQ[#, 5] & /@ FiveList // TableForm;]
AbsoluteTiming[Tab7 = A269254CompositeQ[#, 7] & /@ SevenList // TableForm;]

On my personal machine, this code evaluates in total time $t<15s$, returning the following: Proof Tables. The table essentially tells when we can expect to find a value a(n)=-1 in sequence A269254. This should be the case for any element with row starting True, True, True.

POSTED BY: Brad Klee

After more calculation, we can generalize the quadratic case to the next higher cubic case, as first discussed here. Code for verifying the induction hypothesis and all base cases follows:

t1 = AbsoluteTiming[
  BasisVectors[m_] := Flatten@Outer[
     Times, X[k - #] & /@ Range[2], Y[k - #] & /@ Range[m]];
  T[n_, j_] := Expand[2 ChebyshevT[n, j/2]];
  T2[n_, j_] := T[n, T[n, j]];
  cx = T[3, j];
  cy = Expand[1 + T[3, T[2, j]]];
  cz = Expand[T2[3, j]];
  rep3 = {
    Z[k] -> cz*Z[k - 1] - Z[k - 2],
    X[k] -> cx*X[k - 1] - X[k - 2],
    Y[k] -> cy*Y[k - 1] - cy*Y[k - 2] + Y[k - 3]
    };]

t2 = AbsoluteTiming[
  v012 = Outer[Coefficient, 
     NestList[Expand[# /. k -> k + 1 /. rep3] &, 
      Expand[( Z[k] - ReplaceAll[Z[k], rep3]) /. 
         Z[x_] :> X[x] Y[x] /. rep3]
      , 2], BasisVectors[3], 1];
  ]

t3 = AbsoluteTiming[Expand@Dot[{1, -cx, 1}, v012]]    (* TEST 1 *)

t4 = AbsoluteTiming[
  rec9 = Expand@
    FoldList[Plus, -1, T[#, T[3, j]] & /@ Range[0, 8]][[2 ;; -1]];
  rec6x = {1, 1, Fold[Plus, -1, T[#, j] & /@ Range[0, 2]],
    Fold[Plus, -1, T[#, j] & /@ Range[0, 3]], 1 + T[3, j],
    Fold[Plus, -1, T[#, j] & /@ Range[0, 5]]};
  rec9x  = 
   Join[rec6x, 
    Expand[Plus @@ Times[Partition[rec6x, 3], {-1, T[3, j]}]]];
  rec9y = Expand[Factor@Expand[rec9/rec9x]];
  ]

t5 = AbsoluteTiming[
  Expand@Outer[Expand@
      Dot[
       BasisVectors[3] /. {X[x_] :> rec9x[[3 (x /. k -> 4) - #1]], 
         Y[x_] :> rec9y[[3 (x /. k -> 4) - #1]]}, #2 ] &, {0, 1, 2}, 
    v012, 1]
  ]    (* TEST 2 *)

In time $t < .1s$, the algorithm verifies all requisite zero sums. At "TEST 1", the return is $6$ zeros, while $9$ zeros are returned at "TEST 2". These zero sums depend mainly on the following cubic invariants:

v012
rec9
rec9x
rec9y

outpolys

Discussion of base case will follow on seqfans soon.

POSTED BY: Brad Klee
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract