Forced Drifts in Multiplicative Sequences: Difference between revisions

From Polymath Wiki
Jump to navigationJump to search
OBryant (talk | contribs)
109 edits
Assigning values to primes forces a multiplicative function to have drift
 
OBryant (talk | contribs)
109 edits
→‎drift 6: link to data
 
(3 intermediate revisions by the same user not shown)
Line 1: Line 1:
Each row of each table below give N,k such that, if a multiplicative function f behaves on the primes as described in that row of that table, then  
Each row of each table below give N,k such that, if a multiplicative function f behaves on the primes as described in that row of that table, then  
:<math>f(N-k+1)+ \dots f(N)</math>
:<math>f(N-k+1)+ \dots +f(N)</math>
has absolute value at least drift.
has absolute value at least drift.


Line 7: Line 7:
== drift 2 ==
== drift 2 ==


Tree representation of data
[http://obryant.files.wordpress.com/2010/01/drift2loose.png Tree representation of data]


<table border="1">
<table border="1">
Line 17: Line 17:


== drift 3 ==
== drift 3 ==
[http://obryant.files.wordpress.com/2010/01/drift3loose.png Tree representation of data]


<table border="1">
<table border="1">
Line 36: Line 38:


== drift 4 ==
== drift 4 ==
[http://obryant.files.wordpress.com/2010/01/drift4loose.png Tree representation of data]


<table border="1">
<table border="1">
Line 85: Line 89:
== drift 5 ==
== drift 5 ==


[http://obryant.files.wordpress.com/2010/01/drift5loose.png Tree representation of data]
<p><code>
<table border="1">
<table border="1">
<tr><th>N</th><th>k</th><th>2</th><th>3</th><th>5</th><th>7</th><th>11</th><th>13</th><th>17</th><th>19</th><th>23</th><th>29</th><th>31</th><th>37</th><th>41</th><th>43</th><th>47</th><th>53</th><th>59</th><th>61</th><th>67</th><th>71</th><th>73</th><th>79</th><th>83</th><th>89</th><th>97</th><th>101</th><th>103</th><th>107</th><th>109</th><th>113</th><th>127</th><th>131</th></tr>
<tr><th>N</th><th>k</th><th>2</th><th>3</th><th>5</th><th>7</th><th>11</th><th>13</th><th>17</th><th>19</th><th>23</th><th>29</th><th>31</th><th>37</th><th>41</th><th>43</th><th>47</th><th>53</th><th>59</th><th>61</th><th>67</th><th>71</th><th>73</th><th>79</th><th>83</th><th>89</th><th>97</th><th>101</th><th>103</th><th>107</th><th>109</th><th>113</th><th>127</th><th>131</th></tr>
Line 716: Line 723:
<tr><td>20</td><td>19</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td></tr>
<tr><td>20</td><td>19</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td><td></td></tr>
</table>
</table>
</code></p>


== drift 6 ==
== drift 6 ==


The data for drift 6 is not complete. Kevin has the data for 2 -> 1, but 2 -> -1 doesn't terminate in reasonable time (it gets stuck around modified the Walters example).
The data for drift 6 is not complete. Kevin has the data for 2 -> 1, but 2 -> -1 doesn't terminate in reasonable time (it gets stuck around modified the Walters example).
The data for 2 -> 1 is now posted (in raw form) at [[Forced Drift of Six in Multiplicative Sequences]].
== The code ==
Here's the Mathematica code that generated the data above. Note that it easier to check the data above than it is to generate it. Also note that the code wasn't carefully optimized for speed, even within Mathematica.
<pre>
maxN = 2^18;
Do[
  Which[n == 1, Subscript[x, n] = 1,
  PrimeQ[n], Null,
  True,
  f = FactorInteger[n];
  f2 = (f /. {a_Integer, b_Integer} :>
      If[EvenQ[b], 1, Subscript[x, a]]);
  Subscript[x, n] = Times @@ f2], {n, 1, maxN}];
Remove[f, f2];
shap[last_, length_] :=
  Sum[Subscript[x, i], {i, last - length + 1, last}];
MakeEffort[pm1_] :=
  Module[{guesses, found, CurrentUpperLimit, counter, s, sign},
  guesses =
    Table[Subscript[x, Prime[i]] -> pm1[[i]], {i, Length[pm1]}];
 
  found = False;
  CurrentUpperLimit =
    seq - 1;(*seq is the bound on drift that we are targeting*)
 
  While[Not[found] && CurrentUpperLimit <= Prime[1 + Length[pm1]]^2 &&
      CurrentUpperLimit <= maxN,
    CurrentUpperLimit++;
    counter = CurrentUpperLimit;
    sign = Subscript[x, counter] /. guesses;
    s = If[IntegerQ[sign], sign, 0];
   
    While[s != 0 && counter > 1 && s != sign*seq,
    counter--;
    newvalue = Subscript[x, counter] /. guesses;
    s += If[IntegerQ[newvalue], newvalue, -sign]];
    If[s == sign*seq, found = True]];
  If[found, {pm1, {CurrentUpperLimit,
      CurrentUpperLimit - counter + 1}, s}, "Not Found"]];
Finish[pm1_] := Module[{temp, p1, m1},
  temp = MakeEffort[pm1];
  If[temp === "Not Found",
  p1 = Append[pm1, 1];
  m1 = Append[pm1, -1];
  AppendTo[VertexSet, p1];
  AppendTo[VertexSet, m1];
  AppendTo[
    EdgeSet, {pm1 -> p1, ToString[Prime[Length[p1]]] <> "+"}];
  AppendTo[
    EdgeSet, {pm1 -> m1, ToString[Prime[Length[m1]]] <> "-"}];
  Join[Finish[p1], Finish[m1]],
  LeafLabel[First[temp]] = temp[[2]];
  PrintTemporary["Finished working on " <> ToString[pm1]];
  {temp}]
  ]
seq = 2;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]
tree[2]=TreePlot[EdgeSet/.{}->"root",Left,"root",VertexLabeling->Tooltip, VertexRenderingFunction-> ({White,EdgeForm[Black],Disk[#,.02],Black,Text[ToString[LeafLabel[#2]],#1+{.1,0}]}&)]
seq = 3;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]
tree[3] =
TreePlot[EdgeSet /. {} -> "root", Left, "root",
  VertexLabeling -> Tooltip,
  VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02],
      Black, Text[ToString[LeafLabel[#2]], #1 + {.3, 0}]} &)]
seq = 4;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]
tree[4] =
TreePlot[EdgeSet /. {} -> "root", Left, "root",
  VertexLabeling -> Tooltip,
  VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02],
      Black, Text[ToString[LeafLabel[#2]], #1 + {.22, 0}]} &),
  ImageSize -> 900]
seq = 5;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]
tree[5] =
TreePlot[(EdgeSet /. {} -> "root") /. {Rule[a_, 1] :>
    ToString[a] <> "+", Rule[a_, -1] :> ToString[a] <> "-"}, Left,
  "root", VertexLabeling -> Tooltip,
  VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02],
      Black, Text[ToString[LeafLabel[#2]], #1 + {.1, 0}]} &),
  ImageSize -> 3000]
$RecursionLimit = Infinity;
$IterationLimit = Infinity;
Finish6[pm1_] := Module[{tempeffort, p1, m1},
  tempeffort = MakeEffort[pm1];
  If[tempeffort === "Not Found",
  p1 = Append[pm1, 1];
  m1 = Append[pm1, -1];
  Finish6[p1];
  Finish6[m1];
  NotebookDelete[tempout];
  tempout = PrintTemporary["Finished working on " <> ToString[pm1]],
  Sow[tempeffort]]
  ]
seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {1, 1}] = Reap[Finish6[{1, 1}]][[2, 1]]]
seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {1, -1}] = Reap[Finish6[{1, -1}]][[2, 1]]]
seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {-1, 1}] = Reap[Finish6[{-1, 1}]][[2, 1]]]
seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {-1, -1}] = Reap[Finish6[{-1, -1}]][[2, 1]]]
</pre>

Latest revision as of 19:32, 2 April 2010

Each row of each table below give N,k such that, if a multiplicative function f behaves on the primes as described in that row of that table, then

[math]\displaystyle{ f(N-k+1)+ \dots +f(N) }[/math]

has absolute value at least drift.

Specifically, for each value of drift, the tree of assignments to primes is traversed depth first (exploring 1 before -1). Each time an assignment is made to a prime p, then the values of the implied multiplicative function are updated (they are +1,-1,undetermined). Then for each N (starting with N=1), k (also starting at k=1) is incremented until the interval (N-k,N] contains a sufficient imbalance in +1,-1 to overwhelm the undetermined entries and generate a sufficient drift. If there is no such k, then N is incremented. This continues until a drift is found or [math]\displaystyle{ N=p^2+1 }[/math], in which case the next largest prime is assigned a value.

drift 2

Tree representation of data

Nk23
22+
42-+
32--

drift 3

Tree representation of data

Nk23571113
33++
55+-+
93+--+
73+---
53-++
113-+-++
135-+-+-+
153-+-+--
73-+--
63--+
105---+
87----


drift 4

Tree representation of data

Nk235711131719232931374143
44++
1010+-+
1610+--++
164+--+-+
134+--+--
1710+---+++
524+---++-
1410+---+-
128+----
1210-++++
1614-+++-+
278-+++--
166-++-+
116-++--
124-+-++
354-+-+-++
288-+-+-+-++
304-+-+-+-+-+
4014-+-+-+-+--++
2614-+-+-+-+--+-++
454-+-+-+-+--+-+-
4514-+-+-+-+--+--
3320-+-+-+-+---
196-+-+-+--
284-+-+--
84-+--
74--++
1714--+-+++
566--+-++-
354--+-+-+
1812--+-+--
126--+--
116---++
1712---+-++
254---+-+-++
1174---+-+-+-+
3014---+-+-+--
204---+-+--
144---+--
168----+
164-----+
1312------

drift 5

Tree representation of data

Nk2357111317192329313741434753596167717379838997101103107109113127131
99++
99+-++
1111+-+-+
2121+-+--++
2121+-+--+-+
3333+-+--+--+++
5151+-+--+--++-++
5151+-+--+--++-+-+
13017+-+--+--++-+--
3913+-+--+--++--
5121+-+--+--+-+++
5121+-+--+--+-++-+
13017+-+--+--+-++--
3913+-+--+--+-+-
315+-+--+--+--
4313+-+--+---+++++
939+-+--+---++++-
5121+-+--+---+++-++
955+-+--+---+++-+-
939+-+--+---+++--
3929+-+--+---++-
3121+-+--+---+-
2919+-+--+----
155+-+---
159+--+++
1711+--++-+
1913+--++--+
3125+--++---+++
5145+--++---++-+++
13345+--++---++-++-
519+--++---++-+-++
6517+--++---++-+-+-+
5523+--++---++-+-+--
4311+--++---++-+--
519+--++---++--+++
6517+--++---++--++-+
5523+--++---++--++--
4311+--++---++--+-
419+--++---++---
5145+--++---+-++++
5145+--++---+-+++-+
1895+--++---+-+++--
35213+--++---+-++-+
4311+--++---+-++--
35213+--++---+-+-++
4311+--++---+-+-+-
419+--++---+-+--
3517+--++---+--
279+--++----
175+--+-++
197+--+-+-+
579+--+-+--
185+--+--+
325+--+---++++
3811+--+---+++-+
2895+--+---+++--+
3445+--+---+++---+
445+--+---+++----
665+--+---++-+
2895+--+---++--++
1757+--+---++--+-+
445+--+---++--+--
2895+--+---++---+
4223+--+---++----
245+--+---+-
2213+--+----
1811+---+++
2215+---++-+
2619+---++--+
1207+---++---+
1565+---++----+
2539+---++-----++
4115+---++-----+-
3913+---++------
195+---+-++
239+---+-+-+
357+---+-+--++
379+---+-+--+-+
2097+---+-+--+--+
1895+---+-+--+---++
5511+---+-+--+---+-
5519+---+-+--+----
297+---+-+---
239+---+--++
3911+---+--+-++
395+---+--+-+-+
17111+---+--+-+--+
1725+---+--+-+---+
5735+---+--+-+----
297+---+--+--
379+---+---++++
1559+---+---+++-
5117+---+---++-++
5117+---+---++-+-+
5117+---+---++-+--+
615+---+---++-+---+++
7317+---+---++-+---++-+++
7325+---+---++-+---++-++-
8529+---+---++-+---++-+-+++
9337+---+---++-+---++-+-++-+
999+---+---++-+---++-+-++--+
58411+---+---++-+---++-+-++---
52935+---+---++-+---++-+-+-
7717+---+---++-+---++-+--
699+---+---++-+---++--
1235+---+---++-+---+-+
6359+---+---++-+---+--
5551+---+---++-+----
5111+---+---++--++
5111+---+---++--+-+
3007+---+---++--+--++
34815+---+---++--+--+-+++
7773+---+---++--+--+-++-
6965+---+---++--+--+-+-
6359+---+---++--+--+--
5551+---+---++--+---
4137+---+---++---
2925+---+---+-
2723+---+----
365+----++
3319+----+-+++
3319+----+-++-+
3723+----+-++--+
4329+----+-++---++
5137+----+-++---+-+
535+----+-++---+--+
3725+----+-++---+---
1725+----+-++----+
457+----+-++-----
1217+----+-+-+
2925+----+-+--
335+----+--+++
379+----+--++-+
1907+----+--++--
2925+----+--+-
2319+----+---
139+-----
1311-+++++
1715-++++-+
2119-++++--+
2725-++++---+
295-++++----+
3511-++++-----+
937-++++------
1715-+++-++
2119-+++-+-+
2321-+++-+--+
2927-+++-+---+
3257-+++-+----
289-+++--
155-++-++
177-++-+-+
2717-++-+--++
3713-++-+--+-+++
499-++-+--+-++-+
415-++-+--+-++--
499-++-+--+-+-++
4121-++-+--+-+-+-
3919-++-+--+-+--
499-++-+--+--+++
4121-++-+--+--++-
3919-++-+--+--+-
3111-++-+--+---
3713-++-+---++++
4521-++-+---+++-+
4521-++-+---+++--+
4925-++-+---+++---+
1885-++-+---+++----
4513-++-+---++-++
4513-++-+---++-+-+
4917-++-+---++-+--+
5337-++-+---++-+---++
5921-++-+---++-+---+-
5315-++-+---++-+----
455-++-+---++--++
499-++-+---++--+-+
7113-++-+---++--+--+++++
34859-++-+---++--+--++++-
1365-++-+---++--+--+++-
12613-++-+---++--+--++-
5943-++-+---++--+--+-
5337-++-+---++--+---
4125-++-+---++---
4513-++-+---+-+++
4513-++-+---+-++-+
4917-++-+---+-++--+
3785-++-+---+-++---
37811-++-+---+-+-+
4125-++-+---+-+--
3115-++-+---+--
237-++-+----
165-++--+
207-++---++
2613-++---+-+
4611-++---+--+++++
1767-++---+--++++-
487-++---+--+++-++
1237-++---+--+++-+-+++
8217-++---+--+++-+-++-++
1487-++---+--+++-+-++-+-
13515-++---+--+++-+-++--
2475-++---+--+++-+-+-+
629-++---+--+++-+-+--
587-++---+--+++-+--
4413-++---+--+++--
409-++---+--++-
345-++---+--+-
347-++---+---
817-++----+
589-++-----++
4813-++-----+-+++++
7013-++-----+-++++-++++
13513-++-----+-++++-+++-
1255-++-----+-++++-++-
1269-++-----+-++++-+-
545-++-----+-++++--
7013-++-----+-+++-+++++
35535-++-----+-+++-++++-+
2885-++-----+-+++-++++--
1255-++-----+-+++-+++-
1269-++-----+-+++-++-
545-++-----+-+++-+-
5225-++-----+-+++--
2475-++-----+-++-+++++
8217-++-----+-++-++++-++
8217-++-----+-++-++++-+-+
7425-++-----+-++-++++-+--
6819-++-----+-++-++++--
2475-++-----+-++-+++-+
6213-++-----+-++-+++--
545-++-----+-++-++-
5225-++-----+-++-+-
4417-++-----+-++--
4013-++-----+-+-
325-++-----+--
2419-++------
135-+-+++
2719-+-++-+++
295-+-++-++-+
317-+-++-++--+
4925-+-++-++---+++
1307-+-++-++---++-
939-+-++-++---+-+
4313-+-++-++---+--
399-+-++-++----
295-+-++-+-++
317-+-++-+-+-+
709-+-++-+-+--
2311-+-++-+--
567-+-++--
2315-+-+-++++
2921-+-+-+++-+
3123-+-+-+++--+
355-+-+-+++---
299-+-+-++-++
3111-+-+-++-+-+
355-+-+-++-+--
1207-+-+-++--+
405-+-+-++---++
12411-+-+-++---+-+
527-+-+-++---+--++
6417-+-+-++---+--+-+++
1229-+-+-++---+--+-++-
1207-+-+-++---+--+-+-
6811-+-+-++---+--+--+++
7417-+-+-++---+--+--++-++
4757-+-+-++---+--+--++-+-+
805-+-+-++---+--+--++-+--
35535-+-+-++---+--+--++--
6231-+-+-++---+--+--+-
6029-+-+-++---+--+---
4413-+-+-++---+---
3417-+-+-++----
299-+-+-+-+++
3111-+-+-+-++-+
4121-+-+-+-++--++
997-+-+-+-++--+-++
477-+-+-+-++--+-+-
455-+-+-+-++--+--
997-+-+-+-++---+++
4717-+-+-+-++---++-
4515-+-+-+-++---+-
4515-+-+-+-++----
315-+-+-+-+-++
4115-+-+-+-+-+-++
9111-+-+-+-+-+-+-
1907-+-+-+-+-+--
4115-+-+-+-+--+++
4923-+-+-+-+--++-++
5933-+-+-+-+--++-+-++
6741-+-+-+-+--++-+-+-++
12755-+-+-+-+--++-+-+-+-
6125-+-+-+-+--++-+-+--
6711-+-+-+-+--++-+--+++
7835-+-+-+-+--++-+--++-+
4779-+-+-+-+--++-+--++--++
7913-+-+-+-+--++-+--++--+-
737-+-+-+-+--++-+--++---
6125-+-+-+-+--++-+--+-
7835-+-+-+-+--++-+---+++
855-+-+-+-+--++-+---++-+++
9111-+-+-+-+--++-+---++-++-+
10323-+-+-+-+--++-+---++-++--+++
52537-+-+-+-+--++-+---++-++--++-
12141-+-+-+-+--++-+---++-++--+-++
12141-+-+-+-+--++-+---++-++--+-+-+
12111-+-+-+-+--++-+---++-++--+-+--+
17055-+-+-+-+--++-+---++-++--+-+---++
13541-+-+-+-+--++-+---++-++--+-+---+-
12733-+-+-+-+--++-+---++-++--+-+----
10511-+-+-+-+--++-+---++-++--+--
995-+-+-+-+--++-+---++-++---
7939-+-+-+-+--++-+---++-+-
7333-+-+-+-+--++-+---++--
6929-+-+-+-+--++-+---+-
6121-+-+-+-+--++-+----
455-+-+-+-+--++--
4911-+-+-+-+--+-+++
5921-+-+-+-+--+-++-++
18917-+-+-+-+--+-++-+-+
1237-+-+-+-+--+-++-+--
6711-+-+-+-+--+-++--+++
7519-+-+-+-+--+-++--++-++
4779-+-+-+-+--+-++--++-+-+
52935-+-+-+-+--+-++--++-+--
21617-+-+-+-+--+-++--++--
1245-+-+-+-+--+-++--+-
18917-+-+-+-+--+-++---+
6213-+-+-+-+--+-++----
1907-+-+-+-+--+-+-+
9411-+-+-+-+--+-+--
1907-+-+-+-+--+--++
6413-+-+-+-+--+--+-+++
6125-+-+-+-+--+--+-++-
7625-+-+-+-+--+--+-+-+++
35535-+-+-+-+--+--+-+-++-
12755-+-+-+-+--+--+-+-+-
6231-+-+-+-+--+--+-+--
5423-+-+-+-+--+--+--
4413-+-+-+-+--+---
4813-+-+-+-+---++++
5823-+-+-+-+---+++-+
9035-+-+-+-+---+++--
25913-+-+-+-+---++-
25611-+-+-+-+---+-
3825-+-+-+-+----
207-+-+-+--
2813-+-+--++
277-+-+--+-+
295-+-+--+--+
317-+-+--+---+
355-+-+--+----
277-+-+---++
295-+-+---+-+
317-+-+---+--+
665-+-+---+---
197-+-+----
135-+--++
179-+--+-+
3511-+--+--+++
3511-+--+--++-+
375-+--+--++--+
1177-+--+--++---
237-+--+--+-
215-+--+---
179-+---++
3123-+---+-++++
3729-+---+-+++-+
4133-+---+-+++--+
4335-+---+-+++---+
8815-+---+-+++----
3729-+---+-++-++
1167-+---+-++-+-
3317-+---+-++--
1217-+---+-+-+
2913-+---+-+--
215-+---+--
2719-+----+++
317-+----++-++
439-+----++-+-+++
1369-+----++-+-++-
1725-+----++-+-+-+
4515-+----++-+-+--
399-+----++-+--
439-+----++--++++
1369-+----++--+++-
1725-+----++--++-+
4541-+----++--++--
3935-+----++--+-
3329-+----++---
2117-+----+-
2117-+-----
2017--++++++
3027--+++++-++
3835--+++++-+-++
4441--+++++-+-+-++
3445--+++++-+-+-+-
1257--+++++-+-+--
349--+++++-+--
697--+++++--
3027--++++-+++
3633--++++-++-+
665--++++-++--
1769--++++-+-+
4613--++++-+--+++
827--++++-+--++-
4027--++++-+--+-
3219--++++-+---
229--++++--
2611--+++-+++
307--+++-++-+
4623--+++-++--++
4623--+++-++--+-+
1257--+++-++--+--
3423--+++-++---
2211--+++-+-
187--+++--
249--++-++++
3015--++-+++-+
3257--++-+++--
309--++-++-++
3615--++-++-+-+
3817--++-++-+--+
5433--++-++-+---++++
6443--++-++-+---+++-+
12011--++-++-+---+++--
1885--++-++-+---++-
939--++-++-+---+-
6413--++-++-+----++++
12011--++-++-+----+++-
5631--++-++-+----++-
4823--++-++-+----+-
4419--++-++-+-----
369--++-++--++
3811--++-++--+-+
4619--++-++--+--++
3445--++-++--+--+-
5413--++-++--+---+++
6423--++-++--+---++-++
1227--++-++--+---++-+-
6011--++-++--+---++--
1895--++-++--+---+-
4435--++-++--+----
389--++-++---++
4617--++-++---+-++
5425--++-++---+-+-++
29713--++-++---+-+-+-+
1215--++-++---+-+-+--
29713--++-++---+-+--++
1215--++-++---+-+--+-
5647--++-++---+-+---
1257--++-++---+--
3223--++-++----
189--++-+-
145--++--
2017--+-++++
2421--+-+++-+
707--+-+++--
2421--+-++-++
5613--+-++-+-
577--+-++--
2611--+-+-++
267--+-+-+-+
1565--+-+-+--++
355--+-+-+--+-
359--+-+-+---
257--+-+--++
3113--+-+--+-++
4527--+-+--+-+-+++
13345--+-+--+-+-++-
22511--+-+--+-+-+-+
4313--+-+--+-+-+--
3445--+-+--+-+--++
4313--+-+--+-+--+-
4111--+-+--+-+---
4527--+-+--+--++++
4729--+-+--+--+++-+
5537--+-+--+--+++--+
5941--+-+--+--+++---+
1269--+-+--+--+++----
1257--+-+--+--++-
475--+-+--+--+-+++
9905--+-+--+--+-++-
4317--+-+--+--+-+-
4115--+-+--+--+--
337--+-+--+---
1913--+-+---
2513--+--++
257--+--+-+
1913--+--+--
137--+---
1611---+++
2621---++-+++
697---++-++-
225---++-+-
2211---++--
2419---+-++++
4237---+-+++-++++
12411---+-+++-+++-
1177---+-+++-++-
25611---+-+++-+-++
1725---+-+++-+-+-+
4415---+-+++-+-+--
389---+-+++-+--
1725---+-+++--++++
5337---+-+++--+++-++
5337---+-+++--+++-+-+
7011---+-+++--+++-+--++
1357---+-+++--+++-+--+-
6237---+-+++--+++-+---
4823---+-+++--+++--
1725---+-+++--++-+
4419---+-+++--++--
3813---+-+++--+-
327---+-+++---
3817---+-++-++++
4221---+-++-+++-+
2487---+-++-+++--
967---+-++-++-
427---+-++-+-+++
2487---+-++-+-++-
587---+-++-+-+-++++
607---+-++-+-+-+++-+
6411---+-++-+-+-+++--+
2487---+-++-+-+-+++---
485---+-++-+-+-++-
4621---+-++-+-+-+-
4621---+-++-+-+--
327---+-++-+--
427---+-++--++++
2487---+-++--+++-
8713---+-++--++-++
9035---+-++--++-+-++
6411---+-++--++-+-+-++
2487---+-++--++-+-+-+-
1195---+-++--++-+-+--
4831---+-++--++-+--
2487---+-++--++--
3215---+-++--+-
3013---+-++---
3413---+-+-++++
4221---+-+-+++-++
5433---+-+-+++-+-+++
6443---+-+-+++-+-++-+
645---+-+-+++-+-++--+
2465---+-+-+++-+-++---
485---+-+-+++-+-+-
469---+-+-+++-+--
1297---+-+-+++--++
4617---+-+-+++--+-
4617---+-+-+++---
4221---+-+-++-+++
5433---+-+-++-++-+++
6039---+-+-++-++-++-+
6443---+-+-++-++-++--+
2465---+-+-++-++-++---
485---+-+-++-++-+-
469---+-+-++-++--
5415---+-+-++-+-++++
6021---+-+-++-+-+++-+
6425---+-+-++-+-+++--+
30613---+-+-++-+-+++---
485---+-+-++-+-++-
4621---+-+-++-+-+-
4621---+-+-++-+--
327---+-+-++--
4215---+-+-+-++++
5225---+-+-+-+++-++
5427---+-+-+-+++-+-+
122511---+-+-+-+++-+--
549---+-+-+-+++--++
6419---+-+-+-+++--+-++
12411---+-+-+-+++--+-+-
1185---+-+-+-+++--+--
4811---+-+-+-+++---
1177---+-+-+-++-
4311---+-+-+-+-+++
5523---+-+-+-+-++-+
555---+-+-+-+-++--+
122511---+-+-+-+-++---
5523---+-+-+-+-+-++
555---+-+-+-+-+-+-+
122511---+-+-+-+-+-+--
4529---+-+-+-+-+--
3923---+-+-+-+--
4311---+-+-+--++++
917---+-+-+--+++-
5523---+-+-+--++-++
555---+-+-+--++-+-+
6111---+-+-+--++-+--++
2465---+-+-+--++-+--+-
7121---+-+-+--++-+---+++
9141---+-+-+--++-+---++-++
9111---+-+-+--++-+---++-+-+
915---+-+-+--++-+---++-+--+
8747---+-+-+--++-+---++-+---+
9929---+-+-+--++-+---++-+----
755---+-+-+--++-+---++--
1365---+-+-+--++-+---+-
12411---+-+-+--++-+----
4529---+-+-+--++--
3923---+-+-+--+-
3115---+-+-+---
215---+-+--
2511---+--+++
2915---+--++-+
4127---+--++--+++
2487---+--++--++-
2097---+--++--+-+
2487---+--++--+--
357---+--++---
2111---+--+-
2111---+---
157----++
179----+-+
2517----+--++
3729----+--+-+++
4133----+--+-++-+
2487----+--+-++--
337----+--+-+-
337----+--+--
407----+---
175-----++
2513-----+-+
577-----+--
2613------+
2613-------+
2019--------

drift 6

The data for drift 6 is not complete. Kevin has the data for 2 -> 1, but 2 -> -1 doesn't terminate in reasonable time (it gets stuck around modified the Walters example).

The data for 2 -> 1 is now posted (in raw form) at Forced Drift of Six in Multiplicative Sequences.

The code

Here's the Mathematica code that generated the data above. Note that it easier to check the data above than it is to generate it. Also note that the code wasn't carefully optimized for speed, even within Mathematica. 

maxN = 2^18;

Do[
  Which[n == 1, Subscript[x, n] = 1,
   PrimeQ[n], Null,
   True,
   f = FactorInteger[n];
   f2 = (f /. {a_Integer, b_Integer} :> 
       If[EvenQ[b], 1, Subscript[x, a]]);
   Subscript[x, n] = Times @@ f2], {n, 1, maxN}];
Remove[f, f2];

shap[last_, length_] := 
  Sum[Subscript[x, i], {i, last - length + 1, last}];

MakeEffort[pm1_] := 
  Module[{guesses, found, CurrentUpperLimit, counter, s, sign},
   guesses = 
    Table[Subscript[x, Prime[i]] -> pm1[[i]], {i, Length[pm1]}];
   
   found = False; 
   CurrentUpperLimit = 
    seq - 1;(*seq is the bound on drift that we are targeting*)
   
   While[Not[found] && CurrentUpperLimit <= Prime[1 + Length[pm1]]^2 &&
      CurrentUpperLimit <= maxN,
    CurrentUpperLimit++;
    counter = CurrentUpperLimit;
    sign = Subscript[x, counter] /. guesses;
    s = If[IntegerQ[sign], sign, 0];
    
    While[s != 0 && counter > 1 && s != sign*seq,
     counter--;
     newvalue = Subscript[x, counter] /. guesses;
     s += If[IntegerQ[newvalue], newvalue, -sign]];
    If[s == sign*seq, found = True]];
   If[found, {pm1, {CurrentUpperLimit, 
      CurrentUpperLimit - counter + 1}, s}, "Not Found"]];

Finish[pm1_] := Module[{temp, p1, m1},
  temp = MakeEffort[pm1];
  If[temp === "Not Found",
   p1 = Append[pm1, 1];
   m1 = Append[pm1, -1];
   AppendTo[VertexSet, p1];
   AppendTo[VertexSet, m1];
   AppendTo[
    EdgeSet, {pm1 -> p1, ToString[Prime[Length[p1]]] <> "+"}];
   AppendTo[
    EdgeSet, {pm1 -> m1, ToString[Prime[Length[m1]]] <> "-"}];
   Join[Finish[p1], Finish[m1]],
   LeafLabel[First[temp]] = temp[[2]];
   PrintTemporary["Finished working on " <> ToString[pm1]];
   {temp}]
  ]

seq = 2;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]

tree[2]=TreePlot[EdgeSet/.{}->"root",Left,"root",VertexLabeling->Tooltip, VertexRenderingFunction-> ({White,EdgeForm[Black],Disk[#,.02],Black,Text[ToString[LeafLabel[#2]],#1+{.1,0}]}&)]

seq = 3;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]

tree[3] = 
 TreePlot[EdgeSet /. {} -> "root", Left, "root", 
  VertexLabeling -> Tooltip, 
  VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02], 
      Black, Text[ToString[LeafLabel[#2]], #1 + {.3, 0}]} &)]

seq = 4;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]

tree[4] = 
 TreePlot[EdgeSet /. {} -> "root", Left, "root", 
  VertexLabeling -> Tooltip, 
  VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02], 
      Black, Text[ToString[LeafLabel[#2]], #1 + {.22, 0}]} &), 
  ImageSize -> 900]

seq = 5;
Clear[LeafLabel];
LeafLabel[_] = "";
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq] = Finish[{}]]

tree[5] = 
 TreePlot[(EdgeSet /. {} -> "root") /. {Rule[a_, 1] :> 
     ToString[a] <> "+", Rule[a_, -1] :> ToString[a] <> "-"}, Left, 
  "root", VertexLabeling -> Tooltip, 
  VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02], 
      Black, Text[ToString[LeafLabel[#2]], #1 + {.1, 0}]} &), 
  ImageSize -> 3000]

$RecursionLimit = Infinity;
$IterationLimit = Infinity;

Finish6[pm1_] := Module[{tempeffort, p1, m1},
  tempeffort = MakeEffort[pm1];
  If[tempeffort === "Not Found",
   p1 = Append[pm1, 1];
   m1 = Append[pm1, -1];
   Finish6[p1];
   Finish6[m1];
   NotebookDelete[tempout];
   tempout = PrintTemporary["Finished working on " <> ToString[pm1]],
   Sow[tempeffort]]
  ]

seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {1, 1}] = Reap[Finish6[{1, 1}]][[2, 1]]]

seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {1, -1}] = Reap[Finish6[{1, -1}]][[2, 1]]]

seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {-1, 1}] = Reap[Finish6[{-1, 1}]][[2, 1]]]

seq = 6;
VertexSet = {{}};
EdgeSet = {};
Timing[data[seq, {-1, -1}] = Reap[Finish6[{-1, -1}]][[2, 1]]]
Retrieved from "https://michaelnielsen.org/polymath/index.php?title=Forced_Drifts_in_Multiplicative_Sequences&oldid=3066"