Generating numbers palindromic in two number bases
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}}
(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:
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.