4
$\begingroup$

The purpose of the code below is to generate numbers that are $2d+1$ digit palindromes in number base $b+1$, and are also palindromic in number base $b+3$, where:

The numberToBase is used to convert number $n$ to list representation in number base $b$.

The palindromeInBase returns $n^{\text{th}}$ $2d+1$ digit palindrome in base $b$, for $0\le n\lt b^{d+1}-b^d$.

I'm acquiring palindromes in base $b+1$ and checking if they are palindromic in $b+3$ as well, by looking at their digits in that base when converted to list representation.

I'm wondering how the code below can be improved, and whether there is a way to do this computation faster?

numberToBase[n_, b_] := If[n == 0, {0},
   digits = {};
   number = n;
   While[number > 0,
    digits = Append[digits, Mod[number, b]];
    number = Floor[number/b];
    ];
   Return[Reverse[digits]];
   ];

palindromeInBase[d_, b_, n_] := 
 1 + b^(2 d) + b^d*n + b^(d - 1)*Floor[n/b] - 
  Sum[(b^(i + 1) - b^(i - 1))*Floor[n/b^(d - i + 1)], {i, 1, d - 1}]

d = 3;

For[b = 1, b <= 100, b += 1,
  L = {};
  B1 = b + 1;
  B2 = b + 3;

  For[n = 0, n < (B1)^(d + 1) - (B1)^d, n += 1,
   x = palindromeInBase[d, B1, n];
   If[PalindromeQ[numberToBase[x, B2]], L = Append[L, x];];
  ];

  Print[b, ":", " (" , Length[L], ") " , L];
];
$\endgroup$
  • $\begingroup$ Why are the bases $b+1$ and $b+3$ instead of $b^\prime$ and $b^\prime + 2$? $\endgroup$ – David G. Stork Mar 30 '18 at 17:08
  • 4
    $\begingroup$ Your numberToBase[n, b] is equivalent to the built-in function IntegerDigits[n, b] $\endgroup$ – Bob Hanlon Mar 30 '18 at 17:39
  • $\begingroup$ Also FromDigits might come in handy. $\endgroup$ – Henrik Schumacher Mar 30 '18 at 18:42
2
$\begingroup$

Here are some further ideas:

b1 = 3;
b2 = 4;
d = 3;
a = Flatten[Outer[
    List,
    Range[1, b1 - 1],
    Sequence @@ ConstantArray[Range[0, b1 - 1], d - 1]
    ], d - 1];
b1digits = a[[All, Join[Range[d], Reverse[Range[1, d - 1]]]]];
candidates = FromDigits[#, b1] & /@ b1digits;
b2digits = IntegerDigits[candidates, b2];
palindomes = Pick[n, PalindromeQ /@ IntegerDigits[candidates, b2]]
IntegerDigits[palindomes, b1]
IntegerDigits[palindomes, b2]

{130}

{{1, 1, 2, 1, 1}}

{{2, 0, 0, 2}}

$\endgroup$
2
$\begingroup$

(This is a self-answer after discovering I can use Reduce directly.)



The previous answer gives ideas related to your approach of iterating palindromes.

Here, I present a way to directly compute them instead.


Directly computing $2,3$-palindromes

"...whether there is a way to do this computation faster?"

Rather than brute-force checking palindromes, you can directly solve for them, for individual $b$ values, via Reduce and the corresponding system.

I've implemented get2Palindromes and get3Palindromes for getting palindromes in $b,b-1$ and $b,b-1,b-2$ respectively, using the system from the linked post. (Full code included at the end of this post.)

Since the title is referring to 2-palindromes, here is a sample input:

Do[Print["d = ", 3, ", base: ", base, "; ", Timing[get2Palindromes[3, base]]];, {base, 2, 10}]

And sample output for it:

d = 3, base: 2; {0.015625,{}}
d = 3, base: 3; {0.03125,{}}
d = 3, base: 4; {0.03125,{}}
d = 3, base: 5; {0.046875,{46}}
d = 3, base: 6; {0.0625,{67,98,104}}
d = 3, base: 7; {0.078125,{92,135,178,185}}
d = 3, base: 8; {0.09375,{121,178,235,292,300}}
d = 3, base: 9; {0.09375,{154,227,300,373,446,455}}
d = 3, base: 10; {0.09375,{191,282,373,464,555,646,656}}

If you want to display their palindromic digits, I've also implemented:

getDigits[n_, b_, k_] := 
  MatrixForm[Table[IntegerDigits[n, b - i], {i, 0, k - 1}]];

Which can be used like: getDigits[#, base, 2] & /@ on the palindrome output:

Do[Print["d = ", 3, ", base: ", base, "; ", Timing[getDigits[#, base, 2] & /@ get2Palindromes[3, base]]];, {base, 2, 10}]

Which gives a output in terms of base digits:

enter image description here


Note that Reduce will get very slow quickly for larger $d$. - This is still much faster than doing a brute force search over all palindromes, especially for large $b$. The only exceptions might be very small $b$ in combination with very large $d$, where brute-force might be faster than Reduce.

Here is the code:

(* Helper functions for representations *)
ClearAll[d, palindromePolynom, a, x, baseCoefficients, baseBorrowings,
   b, o, h];
palindromePolynom[d_, x_: x, c_: a] := 
  Sum[a[i + 1] x^i, {i, 0, (d - 1)/2}] + 
   Sum[a[d - i] x^i, {i, (d - 1)/2 + 1, d - 1}];
baseCoefficients[d_, k_: 0] := 
  Reverse[CoefficientList[palindromePolynom[d, x - k], x]];
baseBorrowings[d_, k_: 0, var_: o, 
   b_] := +Join[
    Join[{var[1]}, 
     Table[var[i + 1] - var[i] (b + k), {i, 1, 
       d - 2}]], {-var[d - 1] (b + k)}];

(* base b-1,b-2 representations digits parameterized by o,h *)
ClearAll[coefX, coefA, coefB];
coefX[d_, k_: 0, var_, b_] := 
  baseCoefficients[d, k] + baseBorrowings[d, k, var, b];
coefA[d_, b_, k_: - 1, var_: o] := coefX[d, k, var, b];
coefB[d_, b_, k_: - 2, var_: h] := coefX[d, k, var, b];

(* helper functions for conditions *)
ClearAll[varList, varConds, geCond];
varList[var_, n_] := Table[var[i], {i, 1, n}];
varConds[var_, n_, cond_, c_: 0] := 
  Fold[And, Table[cond[var[i], c], {i, 1, n}]];
geCond[d_, var_, c_: 0] := varConds[var, d, GreaterEqual, c];

(* conditions on digits, bases and parameters *)
ClearAll[paramVars, paramVarsA, paramVarsB, paramVars2, paramVars3, 
  paramConds2, paramConds3, baseConds, baseCondsA, baseCondsB, 
  baseConds2, baseConds3, palCondsA, palCondsB, palConds3];
paramVars[d_] := varList[a, (d + 1)/2];
paramVarsA[d_] := varList[o, d - 1];
paramVarsB[d_] := varList[h, d - 1];
paramVars2[d_] := Join[paramVars[d], paramVarsA[d]];
paramVars3[d_] := Join[paramVars[d], paramVarsA[d], paramVarsB[d]];
paramConds2[d_] := 
  geCond[(d + 1)/2, a] && geCond[d - 1, o] && a[1] >= 1 ;
paramConds3[d_] := 
  geCond[(d + 1)/2, a] && geCond[d - 1, o] && geCond[d - 1, h] && 
   a[1] >= 1;
baseConds[d_, b_] :=  Fold[And, Table[a[i] < b, {i, 1, (d + 1)/2}]];
baseCondsA[d_, b_] :=  
  Fold[And, Table[0 <= coefA[d, b][[i]] < b - 1, {i, 1, d}]] &&  
   coefA[d, b][[1]] >= 1 && coefA[d, b][[d]] >= 1;
baseCondsB[d_, b_] :=  
  Fold[And, Table[0 <= coefB[d, b][[i]] < b - 2, {i, 1, d}]] && 
   coefB[d, b][[1]] >= 1 && coefB[d, b][[d]] >= 1;
baseConds2[d_, b_] :=  baseConds[d, b] && baseCondsA[d, b];
baseConds3[d_, b_] :=  
  baseConds[d, b] && baseCondsA[d, b] && baseCondsB[d, b];
palCondsA[d_, b_] := 
  Fold[And, 
   Table[coefA[d, b][[i]] == coefA[d, b][[d - i + 1]], {i, 
     1, (d + 2)/2 - 1}]] ;
palCondsB[d_, b_] := 
  Fold[And, 
   Table[coefB[d, b][[i]] == coefB[d, b][[d - i + 1]], {i, 
     1, (d + 2)/2 - 1}]];
palConds3[d_, b_] := palCondsA[d, b] && palCondsB[d, b];

(* solving representations under conditions via Reduce *)
ClearAll[reduce2P, reduce3P];
reduce2P[d_, b_, conds_: True] := 
  Reduce[conds && paramConds2[d] && baseConds2[d, b] && 
    palCondsA[d, b], paramVars2[d], Integers];
reduce3P[d_, b_, conds_: True] := 
  Reduce[conds && paramConds3[d] && baseConds3[d, b] && 
    palConds3[d, b], paramVars3[d], Integers];

(* printing out solutions nicely from Reduce results *)
ClearAll[expandBase, extract2, get2Palindromes, extract3, 
  get3Palindromes, getDigits];
expandBase[digs_, base_] := 
  Sum[digs[[i]]*base^(Length[digs] - i), {i, 1, Length[digs]}];
extract2[d_, b_, cond_] := 
  Flatten[expandBase[coefA[d, b], b - 1] /. 
    Delete[FindInstance[#, 
        paramVars2[d]] & /@ (List @@ (cond || a[1] == 1)), -1]];
extract3[d_, b_, cond_] := 
  Flatten[expandBase[coefA[d, b], b - 1] /. 
    Delete[FindInstance[#, 
        paramVars3[d]] & /@ (List @@ (cond || a[1] == 1)), -1]];
get2Palindromes[d_, b_] := 
  Module[{r}, r = reduce2P[d, b]; If[r == False, Return[{}]]; 
   Return[extract2[d, b, r]]];
get3Palindromes[d_, b_] := 
  Module[{r}, r = reduce3P[d, b]; If[r == False, Return[{}]]; 
   Return[extract3[d, b, r]]];
getDigits[n_, b_, k_] := 
  MatrixForm[Table[IntegerDigits[n, b - i], {i, 0, k - 1}]];

Do[Print["d = ", 3, ", base: ", base, "; ", 
    Timing[getDigits[#, base, 2] & /@ 
      get2Palindromes[3, base]]];, {base, 2, 10}];

(*
Do[Print["d = ",3, ", base: ",base,"; \
",Timing[getDigits[#,base,3]&/@get3Palindromes[3,base]]];,{base,8,9}];
Do[Print["d = ",5, ", base: ",base,"; \
",Timing[getDigits[#,base,3]&/@get3Palindromes[5,base]]];,{base,47,47+\
4}];
Do[Print["d = ",7, ", base: ",base,"; \
",Timing[getDigits[#,base,3]&/@get3Palindromes[7,base]]];,{base,291,\
291+11}];
*)

Note that palindromes given by this will have exactly $d$ digits in all of those number bases:

To search for ones with $d,d+k_1,d+k_1+k_2$ digits in bases $b,b-1,b-2$, conditions and coefficients can be easily modified in the above code. Note that such examples for $3$-palindromes are not known yet, and that such examples for $2$-palindromes only exist for small bases $b$ and are finite for all $d$ cases so far.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.