# Finding the largest palindrome which is the product of two 2-digit numbers

My goal is to find the largest palindrome which is the product of two 2-digit numbers using the following program. I want the program to add each palindrome it finds, to the list H. I also want it to test all $n$ from $10$ to $99$, on each respective value of $m$ from $10$ to $99$. Where is the error in the following code?

Clear[H];
H = {};
n = 10;
Do[While[n < 100,
If[PalindromeQ[n*m], H = Append[H, m*n]; n = n + 1,
n = n + 1]], {m, 10, 99}];
Max[H]


## 3 Answers

Your code can be made to work with one minor change. You must initialize n at each step of your Do-loop.

H = {};
Do[
n = 10;
While[n < 100,
If[PalindromeQ[n*m], H = Append[H, m*n]; n = n + 1, n = n + 1]],
{m, 10, 99}]
Max[H]


9009

Staying with procedural methods, I would would still recommend searching in the other direction, large products to small, as a better approach. With that approach you can break out the loops as soon as you find the 1st palindromic integer. The following code is simpler and faster than yours.

Module[{m, n, result},
result = \$Failed;
m = 99;
While[m > 0,
n = 99;
While[n > 0,
If[PalindromeQ[n m], result = n m; n = 0; m = 0];
n--];
m--];
result]


9009

sub = Subsets[Range[10, 99], {2}];

res = Last@Select[Times @@@ sub, IntegerDigits[#] == Reverse@IntegerDigits[#] &]


9009

Extract[sub, FirstPosition[Times @@@ sub, res]]


{91, 99}

• Replace Permutations[Range[10, 99], {2}] with Subsets[Range[10, 99], {2}] to reduce the search space (multiplication is commutative). If you're already on version 10.3 or higher, use PalindromeQ[] for testing. – J. M. is away Jul 30 '17 at 22:35
• Thanks, I changed to Subsets. - Still on V10 – eldo Jul 30 '17 at 22:47

You can use DivisorPairs[n] from a post by Mr.Wizard to find two numbers whose product is n.

DivisorPairs[n_] :=
Thread[{#, Reverse[#]}][[ ;; Ceiling[Length[#]/2]]] &[Divisors[n]]


The second helper function twoDigitProductQ[n] tests that both elements in the pair have 2 digits.

twoDigitProductQ[n_] :=
DeleteDuplicates[
Pick[#, IntegerLength[#], {2, 2}] &[DivisorPairs[n]]] =!= {{}}


Now count down from the maximum as @m_goldberg suggests.

Do[
If[PalindromeQ[n] && twoDigitProductQ[n], Return[n]],
{n, 99*99, 1, -1}]


9009