Introduction:

There is a sum of terms whose exponents are equal to the number of terms and, as a result, generates a number formed from each initial term together (without the exponents). Here, I'll show you some methods for finding these special sums to varying degrees.

The simple definition and one of the simplest example:

I did not give much importance to cases like 10 followed by zeros, because it is easy to find; and I considered other cases in which the example definition above is modified to accept more complex cases. Example:

Methods:

There are some methods (here I expose 6 methods) to obtain the desired results. They appear in order of efficiency and are described below. The general results are at the end of the post.

• Solve:

The simplest method for finding solutions to this type of problem is using Solve[].

sol[n_] := 
 Module[{nn, sx, bb, r, s}, 
  nn = Table[
    StringJoin["p", i // ToString] // ToExpression, {i, Range@n}]; 
  sx = Sum[(nn[[k]])^n, {k, 1, n}] == 
    Sum[Table[10^j, {j, 0, n - 1}][[y]]*nn[[y]], {y, 1, n}]; 
  bb = Reverse@Solve[nn < 11 && sx, nn, PositiveIntegers]; 
  r = Reverse@nn /. bb; 
  s = Map[Map[Superscript[#, n // ToString] &, r[[#]]] &, 
    Range@Length@r]; 
  Thread[{s, 
    Map[StringJoin@Map[ToString, r[[#]]] &, Range@Length@r]}]]

However, this way has its limitations, for example, it works only for degree 2 and degree 3, that is, to find solutions for higher degrees, had to be creative.

• Solve/Mod:

An improvement in solving this problem was to use Mod[] together with Solve[], which compares the numbers in the rest of the division (in this case, division by 9), to find out later which one has true results with the help of If[] and TrueQ[].

solMod[n_] := 
 Module[{ap, bp, r, s}, 
  ap = Table[
    StringJoin["p", i // ToString] // ToExpression, {i, Range@n}]; 
  bp = ap /. 
    Solve[$MaxPiecewiseCases = Infinity; 
     ap < 11 && Mod[Total[ap^n], 9] == Mod[Total[ap], 9], ap, 
     PositiveIntegers];
  r = DeleteCases[
    Table[If[
      TrueQ[Sum[bp[[k, y]]^n, {y, 1, Length@bp[[1]]}] == 
         Sum[bp[[k, z]]*10^(z - 1), {z, 1, Length@bp[[1]]}]] == True, 
      Reverse[bp[[k]]], {}], {k, 1, Length@bp}], {}]; 
  s = Map[Map[Superscript[#, n // ToString] &, r[[#]]] &, 
    Range@Length@r]; 
  Thread[{s, 
    Map[StringJoin@Map[ToString, r[[#]]] &, Range@Length@r]}]]

However, this way is also very limited, as it works for degree 2 to degree 4, only a slight improvement.

• Solve/Table:

With Solve and Table it was possible to have a significant improvement, since Table checks many simultaneous results while the number of unknowns is kept at 1 or 2 variables.

solTab[n_, d_: 10] := 
 Module[{a1, b, h, c, dx, r, s}, 
  a1 = Table[
    StringJoin["e", i // ToString] // ToExpression, {i, Range@n}]; 
  b = Sum[(a1[[k]])^n, {k, 1, n}] == 
    Sum[Table[10^j, {j, 0, n - 1}][[y]]*a1[[y]], {y, 1, n}]; 
  dx = If[n - 1 > 1, 
    NumericArray[Tuples[Range@d, {n - 1}], "UnsignedInteger8"], 
    If[n - 1 == 1, Range@d, {{}}]]; 
  h = Union@
    DeleteCases[
     Table[c = 
       Solve[a1[[;; -2]] == Normal@(dx[[u]]) && b, a1, 
        PositiveIntegers]; 
      Reverse[If[c == {}, {{}}, c][[1]]], {u, 1, Length@dx}], {}]; 
  r = Table[Reverse@a1 /. (h[[x]]), {x, 1, Length@h}]; 
  s = Map[Map[Superscript[#, n // ToString] &, r[[#]]] &, 
    Range@Length@r]; 
  Thread[{s, 
    Map[StringJoin@Map[ToString, r[[#]]] &, Range@Length@r]}]]

Doing this way it was possible to find solutions up to (barely) degree 7! However, the time required to test all possibilities within Table (and Solve) was still a challenge.

• Solve/Random:

I found that to overcome the evaluation times achieved with Table, the best way was with RandomInteger[], because that way the result is found more quickly than if it is tested in sequence. Another point of this method is that, as it uses random tests, the best way was to add a While[] loop, and the result is given only when 1 or more answers are acquired.

solRan[n_, z_: 10, d_: 10] := 
 Module[{a1, b, h, c, s, r, sr}, 
  a1 = Table[
    StringJoin["e", i // ToString] // ToExpression, {i, Range@n}]; 
  b = Sum[(a1[[k]])^n, {k, 1, n}] == 
    Sum[Table[10^j, {j, 0, n - 1}][[y]]*a1[[y]], {y, 1, n}]; s = 1; 
  While[True, 
   If[(h = Union@
        DeleteCases[
         Table[c = 
           Solve[a1[[;; -2]] == RandomInteger[{1, d}, n - 1] && b, a1,
             PositiveIntegers]; Reverse[If[c == {}, {{}}, c][[1]]], 
          z], {}]) != {}, Break[]]; s++]; 
  r = Table[Reverse@a1 /. h[[x]], {x, 1, Length@h}]; 
  sr = Map[Map[Superscript[#, n // ToString] &, r[[#]]] &, 
    Range@Length@r]; 
  Thread[{sr, 
    Map[StringJoin@Map[ToString, r[[#]]] &, Range@Length@r]}]]

The evaluation time of this method was promising, however, as it uses random tests, the result may come promptly or take much longer than expected. This method is also complicated for higher degrees because the chance of a response coming out randomly decreases by powers of 10. The maximum practical degree for this method is also degree 7.

• Table:

To overcome degree 7, I realized that the major impediment is the time of the Solve[] command, so when I discarded Solve and used only If, Table and TrueQ, the speed jumped, and I was able to go beyond degree 7 (to 8). In the example after the code, I excluded the results formed by 10 followed by zeros.

tab[n_, v_: 10, type_: "UnsignedInteger8"] := 
 Module[{a, r, s}, 
  a = NumericArray[
    DeleteCases[Tuples[Table[x, {x, 0, v}], {n}], {0, __}], type]; 
  r = Union@
    DeleteCases[
     Table[If[
       TrueQ[Total@Map[#^n &, Normal@a[[i]]] == 
          ToExpression@StringJoin@Map[ToString, Normal@a[[i]]]] == 
        True, Normal@a[[i]], {}], {i, 1, Length@a}], {}]; 
  s = Map[Map[Superscript[#, n // ToString] &, r[[#]]] &, 
    Range@Length@r]; 
  Thread[{s, 
    Map[StringJoin@Map[ToString, r[[#]]] &, Range@Length@r]}]]

The problem this way is that it starts to demand a lot of memory, to give you an idea, the available limit to carry out the operations (at least in the notebook on my pc) is 80-90% of 1 GB or 800-900MB, limit of which is achieved when the tests are carried out at degree 8. Thus, the maximum degree reached by this method was 8. See the memory consumption below (even with NumericArray-UnsignedInteger8):

a = NumericArray[Tuples[Range@10, {8}], "UnsignedInteger8"]
ByteCount@a

Table[n = i; {Style[i, Red], 
  Ceiling[x /. Solve[x^n*n == 800000000, {x}, PositiveReals]]}, {i, 4,
   9}]

• Table/Random:

The degree 9, if evaluated with Table as in the previous method, would occupy 9GB! To cross this barrier from the 8th degree to the 9th degree I had to merge Table with RandomInteger. In this way, part of the sample is sequential and another part of the sample is random, to be joined with Join[]. A good thing is that the time to find the answer has improved, but on the other hand the time has turned random. Again, it has a While loop.

tabRan[n_] := 
 Module[{cc, a, s, h, sr}, 
  cc = If[n - 3 < 4, 
    NumericArray[
     DeleteCases[Tuples[Table[x, {x, 0, 10}], {n}], {0, __}], 
     "UnsignedInteger8"], 
    NumericArray[
     DeleteCases[Tuples[Table[x, {x, 0, 10}], {n - 4}], {0, __}], 
     "UnsignedInteger8"]]; s = 1; 
  While[True, 
   If[a = If[n - 3 < 4, cc, 
      NumericArray[
       Flatten[Table[
         Join[Normal[cc[[i]]], RandomInteger[10, 4]], {i, 1, 
          Length@cc}], 1], "UnsignedInteger8"]]; (h = 
       Union@DeleteCases[
         Table[If[
           TrueQ[Total@Map[#^n &, Normal@a[[i]]] == 
              ToExpression@StringJoin@Map[ToString, Normal@a[[i]]]] ==
             True, Normal@a[[i]], {}], {i, 1, Length@a}], {}]) != {}, 
    Break[]]; s++]; 
  sr = Map[Map[Superscript[#, n // ToString] &, h[[#]]] &, 
    Range@Length@h]; 
  Thread[{sr, 
    Map[StringJoin@Map[ToString, h[[#]]] &, Range@Length@h]}]]

Of course, the basic scheme above was done in a way that the random values are the same at each stage, because Join[] was done only once and after that the definition was used elsewhere. This final method was successful in finding at least one solution for degree 9 and there is potential to improve it and maybe try degree 10 or degree 11 (!?).

Results:

• Time and limitations of the methods:

Below is the table with the limitations of each method and the approximate time to calculate the response at each degree. The times below can vary a lot, the random methods can vary even more, so they are just samples of the tests I performed.

• Results (including degree 9):

Below is a table with the results I obtained combining the various methods (from degree 2 to degree 9).

These above, are just some of the possible results to be obtained and there are many others, mainly using more available memory. The challenge was really to get solutions for degree 9 to more. Perhaps with some other method this is possible more easily (taking into account the evaluation time x efficiency). The next challenge is to find a solution for degree 10 and 11, and who knows, maybe someday, I or someone will have ideas to achieve these goals.

Thanks.