Integer Complexity

by Ed Pegg Jr, with help from Stephen Wolfram

Plus,Times

f[a_, b_]  :=  If[a > b, a  + b,  a  b]

NextStep :=  
        Join[A, {Complement[
              Union[Flatten[
                  Table[Outer[f, A[[n]], A[[Length[A] - n + 1]]], {n, 
                      1, Length[A]}]]], Union[Flatten[A]]]}];

A  =  {{1}, {2}};

Do[{A  = NextStep;}, {37}]

Take[A, 12]

A005245  =  Table[0, {150000}];

Do[Do[
        A005245[[ A[[j, k]] ]]  =  j,  {k, 1, 
          Length[A[[j]]]}], {j, 1, 39}]

ListPlot[Take[A005245, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 25}}]

primelist[a_Integer]  :=  
      Flatten[Map[Table[First[#], {Last[#]}] &, FactorInteger[a]]]

primeprocess[{a_Integer,  b_List}]  :=  {a + Length[b], 
        b - 1}

primestep[aa_List]  := 
      With[{bb  =  
            primeprocess[{First[aa]  +  Total[Select[Last[aa], EvenQ]], 
                Select[Last[aa], OddQ]}]}, 
{First[bb], 
          Flatten[Map[primelist, Last[bb]]]}]

AriasdeReyna[a_Integer]  :=  
      If[a == 1, 1, 
        First[FixedPoint[primestep, {0,  primelist[a]}]]]

A061373  =  Table[AriasdeReyna[n], {n, 1, 150000}];

ListPlot[Take[A061373, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 25}}]

complexitydiferences  =  A061373   -  A005245;

Table[Count[complexitydiferences, k], {k, 0, 7}]

Position[complexitydiferences, 7]

ListPlot[Take[complexitydiferences, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 5}}]

Map[First, A]

Map[
      Mod[#, 120] &, {1, 2, 3, 4, 5, 7, 10, 11, 17, 22, 23, 41, 47, 59, 89, 
        107, 167, 179, 263, 347, 467, 683, 719, 1223, 1438, 1439, 2879, 3767, 
        4283, 6299, 10079, 11807, 15287, 21599, 33599, 45197, 56039, 81647, 
        98999, 163259, 203999, 241883, 371447, 540539, 590399, 907199, 
        1081079, 1851119, 2041199, 3243239, 3840479, 6562079, 
        8206559}]

Map[Last, A]

Plus, Times, Complex Numbers

f[a_, b_]  :=  If[Abs[a] > Abs[b], a + b,  a b]

g[a_, b_]  :=  If[Abs[a] <= Abs[b], a + b,  a b]

NextStep :=  
        Join[A, {Complement[
              Union[Flatten[{Table[
                      Outer[f, A[[n]], A[[Length[A] - n + 1]]], {n, 
                        1, Length[A]}], 
                    Table[Outer[g, A[[n]], 
                        A[[Length[A] - n + 1]]], {n, 1, Length[A]}]}]], 
              Union[Flatten[A]]]}];

The only case where a+a is the optimal form is 1+1=2.  For any other case, 2 a is more optimal than a+a. An extra term is needed at the start to handle the special case.

A  =  {{I}, {2 I,  -1}};

Do[{A  = NextStep;}, {17}]

ComplexPlusTimes  =  Table[22, {201}, {201}];

Do[Do[
        If[202 > Re[A[[j, k]]] + 101 > 0  && 
            202 > Im[A[[j, k]]] + 101  > 0, 
          ComplexPlusTimes[[ Re[A[[j, k]]] + 101, 
                Im[A[[j, k]]] + 101 ]]  =  j],  {k, 1, 
          Length[A[[j]]]}], {j, 1, 19}]

RasterGraphics[state_, colors_:  2, size_:  1] := 
      With[{dim = Reverse[Dimensions[state]]}, 
        Graphics[Raster[Reverse[1 - state/(colors - 1)]], 
          AspectRatio -> Automatic, 
          PlotRange -> {{0, dim[[1]]}, {0, dim[[2]]}}, 
          ImageSize -> size*dim + 1]]

RasterGraphics[Reverse[Transpose[ComplexPlusTimes]], 22, 2] // 
      Show

(2 a + b - 1)

f[a_, b_]  :=  (2 a + b - 1)

NextStep :=  
        Join[A, {Complement[
              Union[Flatten[
                  Table[Outer[f, A[[n]], A[[Length[A] - n + 1]]], {n, 
                      1, Length[A]}]]], Union[Flatten[A]]]}];

A  =  {{1}};

Do[{A  = NextStep;}, {23}];

twoaplusbdata  =  Table[0, {1000}];

Do[Do[
        twoaplusbdata[[ A[[j, k]] ]]  =  j,  {k, 1, 
          Length[A[[j]]]}], {j, 1, 24}]

ListPlot[Take[twoaplusbdata, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 25}}]

BitXor[2 a,b]+1

f[a_, b_]  :=  BitXor[2 a,  b] + 1

NextStep :=  
        Join[A, {Complement[
              Union[Flatten[
                  Table[Outer[f, A[[n]], A[[Length[A] - n + 1]]], {n, 
                      1, Length[A]}]]], Union[Flatten[A]]]}];

A  =  {{1}};

Do[{A  = NextStep;}, {17}]

BitXordata  =  Table[0, {1000}];

Do[Do[
        BitXordata[[ A[[j, k]] ]]  =  j,  {k, 1, 
          Length[A[[j]]]}], {j, 1, 18}]

ListPlot[Take[BitXordata, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 25}}]

BitXor[2 a,b]-1

f[a_, b_]  :=  BitXor[2 a,  b] - 1

NextStep :=  
        Join[A, {Complement[
              Union[Flatten[
                  Table[Outer[f, A[[n]], A[[Length[A] - n + 1]]], {n, 
                      1, Length[A]}]]], Union[Flatten[A]]]}];

A  =  {{1}};

Do[{A  = NextStep;}, {20}]

A  =  Map[Select[#, Positive] &, A];

BitXordata2  =  Table[0, {1000}];

Do[Do[
        BitXordata2[[ A[[j, k]] ]]  =  j,  {k, 1, 
          Length[A[[j]]]}], {j, 1, 20}]

ListPlot[Take[BitXordata2, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 25}}]

BitOr[2 a,b]-1

f[a_, b_]  :=  BitOr[2 a,  b] - 1

NextStep :=  
        Join[A, {Complement[
              Union[Flatten[
                  Table[Outer[f, A[[n]], A[[Length[A] - n + 1]]], {n, 
                      1, Length[A]}]]], Union[Flatten[A]]]}];

A  =  {{1}};

Do[{A  = NextStep;}, {17}]

BitOrdata  =   Table[0, {1000}];

Do[Do[
        BitOrdata[[ A[[j, k]] ]]  =  j,  {k, 1, 
          Length[A[[j]]]}], {j, 1, 18}]

ListPlot[Take[BitOrdata, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 25}}]

An exact form for BitOr[2a,b]-1 was found by Stephen Wolfram and Ed Pegg.

functionbitor [x_] := With[{i  =  IntegerDigits[x,  2]},  
          Apply[Plus,  i  +  1]  +  
            i[[2]] (1  +  i[[3]]) -  1]

(a^2 + ab)

f[a_, b_]  :=  
      If[a^2  +  a b < 1500, a^2  +  a b, 1]

NextStep :=  
        Join[A, {Complement[
              Union[Flatten[
                  Table[Outer[f, A[[n]], A[[Length[A] - n + 1]]], {n, 
                      1, Length[A]}]]], Union[Flatten[A]]]}];

A  =  {{1}};

Do[{A  = NextStep;}, {17}]

asquaredplusab  =  
        Table[Position[A, i][[1, 1]], {i, 1, 500}];

asquaredplusab  =  Table[0, {1000}];

Do[Do[
        asquaredplusab[[ A[[j, k]] ]]  =  j,  {k, 1, 
          Length[A[[j]]]}], {j, 1, 18}]

ListPlot[Take[asquaredplusab, 500], AspectRatio ->  1/7, 
      Prolog ->  AbsolutePointSize[ .01], 
      PlotRange -> {All, {0, 25}}]