LambertW(k)/k by tetration for natural numbers.

Question

This Mathematica program:

Clear[nn, t, n, k, i];
nn = 85;
t[1, 1] = 1;
t[n_, k_] := 
  t[n, k] = If[n >= k, Exp[-Sum[N[t[n - i, k]], {i, 1, k - 1}]], 1];
Table[t[nn, k]^-1, {k, 1 + 1, 12 + 1}]
Table[N[n/ProductLog[n]], {n, 1, 12}]

seems to give LambertW(n)/n for n=1 to 12 by tetration.

Output:

{1.76322, 2.34575, 2.85739, 3.32732, 3.76868, 4.18881, 4.59206, 4.98129, 5.36656, 5.72993, 6.07439, 6.44781}

Compared to Mathematicas buildt-in n/LambertW(n):

{1.76322, 2.34575, 2.85739, 3.32732, 3.76868, 4.18876, 4.59214, \ 4.9819, 5.36028, 5.72893, 6.08911, 6.44186}

Works much better in Microsoft Excel:

=IF(OR(ROW()=1; COLUMN()=1); 1; IF(ROW()>=COLUMN(); EXP(-SUM(INDIRECT(ADDRESS(ROW()-COLUMN()+1; COLUMN(); 4)&":"&ADDRESS(ROW()-1; COLUMN(); 4); 4)));1))

(Excel formula needs to be entered in cell A1, filled down to about row 1000. Each column then has the reciprocal value.

In latex the the recurrence is:

$$t(1,1)=1$$ $$t(\text{n$\_$},\text{k$\_$})\text{:=}t(n,k)=\text{If}\left[n\geq k,\exp \left(-\sum _{i=1}^{k-1} t(n-i,k)\right),1\right]$$

In english the recurrence is:

If $n$ is greater than equal to $k$: $$t(n,k)=\exp \left(-\sum _{i=1}^{k-1} t(n-i,k)\right)$$ else $$t(n,k)=1$$

The infinite table $t(n,k)$ of tetration starts:

$$\begin{array}{llllll} 1 & 1 & 1 & 1 & 1 & 1 \\ \frac{1}{e} & 1 & 1 & 1 & 1 & 1 \\ e^{-1/e} & \frac{1}{e^2} & 1 & 1 & 1 & 1 \\ e^{-e^{-1/e}} & e^{-1-\frac{1}{e^2}} & \frac{1}{e^3} & 1 & 1 & 1 \\ e^{-e^{-e^{-1/e}}} & e^{-\frac{1}{e^2}-e^{-1-\frac{1}{e^2}}} & e^{-2-\frac{1}{e^3}} & \frac{1}{e^4} & 1 & 1 \\ e^{-e^{-e^{-e^{-1/e}}}} & e^{-e^{-1-\frac{1}{e^2}}-e^{-\frac{1}{e^2}-e^{-1-\frac{1}{e^2}}}} & e^{-1-\frac{1}{e^3}-e^{-2-\frac{1}{e^3}}} & e^{-3-\frac{1}{e^4}} & \frac{1}{e^5} & 1 \end{array}$$

The claim is that $\lim_{n->\infty}\text{LambertW(k)/k} = t(n,k)$

Why does it work? Is it known?

Link to limit representation of LambertW

LambertW(x) is also called ProductLog(x).

---

Tetration appears to work for complex numbers too:

Clear[nn, t, n, k, i];
nn = 85;
t[1, 1] = 1;
t[n_, k_] := 
  t[n, k] = If[n >= k, Exp[-Sum[N[I*t[n - i, k]], {i, 1, k - 1}]], I];
Table[t[nn, k]*(k - 1)*I, {k, 1 + 1, 6 + 1}]
Table[N[ProductLog[n*I]], {n, 1, 6}]

recurrence output: {0.374699 + 0.576413 I, 0.683408 + 0.743386 I, 0.898668 + 0.826935 I, 1.06393 + 0.87901 I, 1.19448 + 0.915874 I, 1.31837 + 0.936584 I}

compared too Mathematica: {0.374699 + 0.576413 I, 0.683408 + 0.743386 I, 0.89871 + 0.826955 I, 1.06384 + 0.879803 I, 1.19805 + 0.917331 I, 1.31129 + 0.945888 I}

---

Tetration of integer multiples of 1/ZetaZero[1]:

Clear[nn, t, n, k, i];
nn = 75;
t[1, 1] = 1;
t[n_, k_] := 
  t[n, k] = 
   If[n >= k, 
    Exp[-Sum[N[(1/ZetaZero[1])*t[n - i, k]], {i, 1, k - 1}]], (1/
      ZetaZero[1])];
Table[t[nn, k]*(k - 1)*(1/ZetaZero[1]), {k, 1 + 1, 6 + 1}]
Table[N[ProductLog[n*(1/ZetaZero[1])]], {n, 1, 6}]

Tetration of n*(1/ZetaZero[1]):

{0.00736674 - 0.0697969 I, 0.0235635 - 0.136089 I, 0.0466203 - 0.197008 I, 0.07436 - 0.251797 I, 0.104914 - 0.300521 I, 0.136894 - 0.343688 I}

Mathematicas ProductLog[n*(1/ZetaZero[1])]:

{0.00736674 - 0.0697969 I, 0.0235635 - 0.136089 I, 0.0466203 - 0.197008 I, 0.07436 - 0.251797 I, 0.104914 - 0.300521 I, 0.136894 - 0.343688 I}

---

In[217]:= Clear[a, b, c, d]
a = 1;
b = 1;
c = 1;
d = 1;
e = 1;
f = 1;
Do[
 a = N[Exp[(-a - b - c - d - e - f)]];
 b = N[Exp[(-a - b - c - d - e - f)]];
 c = N[Exp[(-a - b - c - d - e - f)]];
 d = N[Exp[(-a - b - c - d - e - f)]];
 e = N[Exp[(-a - b - c - d - e - f)]];
 f = N[Exp[(-a - b - c - d - e - f)]];
 , {n, 1, 575}]
a

Out[225]= 0.238734

In[226]:= N[LambertW[6]/6]

Out[226]= 0.238734

By integrating the variables in the do loop:

Clear[nn, t, n, k, i];
nn = 85;
t[1, 1] = 1;
t[n_, k_] := 
  t[n, k] = 
   If[n >= k, Exp[-Sum[N[(t[n - i, k]^2)/2], {i, 1, k - 1}]], 1];
Table[t[nn, k], {k, 1 + 1, 6 + 1}]
Table[N[Sqrt[ProductLog[n]/n]], {n, 1, 6}]

we appear to get:

$$\sqrt{\frac{W(n)}{n}}$$

Integrating once more:

Clear[nn, t, n, k, i];
nn = 85;
t[1, 1] = 1;
t[n_, k_] := 
  t[n, k] = 
   If[n >= k, Exp[-Sum[N[(t[n - i, k]^3)/6], {i, 1, k - 1}]], 1];
Table[t[nn, k], {k, 1 + 1, 12 + 1}]
Table[N[(ProductLog[n/2]/(n/2))^(1/3)], {n, 1, 12}]

we appear to get:

$$\sqrt[3]{\frac{W\left(\frac{n}{2}\right)}{\frac{n}{2}}}$$

Doing:

Clear[nn, t, n, k, i];
nn = 85;
t[1, 1] = 1;
t[n_, k_] := 
  t[n, k] = 
   If[n >= k, Exp[-Sum[N[(t[n - i, k]^(1/2))*2], {i, 1, k - 1}]], 1];
Table[t[nn, k], {k, 1 + 1, 6 + 1}]
Table[N[(ProductLog[n]/n)^2], {n, 1, 6}]

we appear to get:

$$\left(\frac{W(n)}{n}\right)^2$$

Shifting to normal exponentiation:

Clear[nn, t, n, k, i];
nn = 75;
t[1, 1] = 1;
t[n_, k_] := 
  t[n, k] = 
   If[n >= k, k^(-Sum[N[(t[n - i, k])/(k - 1), 12], {i, 1, k - 1}]), 
    1];
Table[t[nn, k], {k, 1 + 1, 6 + 1}] 
Table[N[ProductLog[Log[n]]/Log[n], 12], {n, 1 + 1, 6 + 1}]

we seem to get:

$$\frac{W(\log (n))}{\log (n)}$$

---

Better do-loops:

Clear[a, b, c, d, bigNumber]
a = RandomReal[] 10;
b = RandomReal[] 10;
c = RandomReal[] 10;
bigNumber = 10000000000000000000000000;
Monitor[Do[
  a = Round[(Exp[-(a + b + c)])*bigNumber]/bigNumber;
  b = Round[(Exp[-(a + b + c)])*bigNumber]/bigNumber;
  c = Round[(Exp[-(a + b + c)])*bigNumber]/bigNumber;
  , {n, 1, 2000}], n]
N[a, 30]
N[b, 30]
N[c, 30]
N[LambertW[3]/3, 30]

---

Clear[a, b, c, d, bigNumber]
a = RandomReal[] 10;
b = RandomReal[] 10;
c = RandomReal[] 10;
d = RandomReal[] 10;
bigNumber = 10000000000000000000000000;
Monitor[Do[
  a = Round[(Exp[-(a + b + c + d)])*bigNumber]/bigNumber;
  b = Round[(Exp[-(a + b + c + d)])*bigNumber]/bigNumber;
  c = Round[(Exp[-(a + b + c + d)])*bigNumber]/bigNumber;
  d = Round[(Exp[-(a + b + c + d)])*bigNumber]/bigNumber;
  , {n, 1, 2000}], n]
N[a, 30]
N[b, 30]
N[c, 30]
N[d, 30]
N[LambertW[4]/4, 30]

Answer 1

Concerning the first question. Let's rewrite the generation-rule of the columns of your table $t(n,k)$ (where it would be helpful a) if we would write $t(r,c)$ to make clear what is column- and what row index and b) if it would be explicite, whether it begins wiith 0 or 1 - there are different conventions around).

---

Well. For column $0$ we have $$ x_{0} = 1 \qquad \qquad x_k=\exp(-x_{k-1})$$
If we assume, that this converges with the index $k$ to some $$c_0= \lim_{k \to \infty} x_k $$ then we have approximation to the equality $$ \begin{array} {} &c_0 &=& \exp (-c_0) \\ &c_0 \cdot \exp c_0 &=& 1 \end{array}$$ and it follows $$ \begin{array} {} \to& c_0 &=& W(1) \end{array} $$

---

For the next column ($1$) we have $$ x_{0} = 1 \\ x_{1} = 1 \\ x_k=\exp(-(x_{k-1}+x_{k-2}))$$
If again we assume, that this converges such that $x_k$ with high indices approach equality and $$c_1= \lim_{k \to \infty} x_k $$then in the limit we can write $$ \begin{array} {} &c_1 &=& \exp (-(c_1+c_1)) \\ &c_1 \cdot \exp 2c_1 &=& 1 \\ &2c_1 \cdot \exp 2c_1 &=& 2 \\ \end{array}$$ and it follows $$ \begin{array} {} \to& 2c_1 &=& W(2) \\ & c_1 &=& W(2)/2 \\ \end{array} $$

---

I think it is easy to see, how this generalizes to the other columns.

Now after we have some idea what it would be if we had convergence, we must now attempt to prove that convergence or at least to find an interval of convergence.

---

Btw, the process reminds me more to the concept of "continued fractions" than fractional/generalized iteration of exponentials, so I would also tend to avoid the term "tetration" for this; it's somehow "continued reciprocal exponentiation" or the like and I think it has a nice and interesting flavour in its own. Remember the matrix-notation for the representation of the infinite periodic continued fractions, which converge to square roots of rational numbers.

[added] Here is a picture of the convergence-behaviour along the columns in the t(n,k)-table. Interesting the oscillation around, but towards, the fixpoint. Similar to the greater/smaller-approximation with the continued fractions...