# How to find palindromic numbers (Project Euler #4)?

I'm trying to solve the fourth Project Euler's problem with this:

Clear["Global*"]

a = Range[800, 999]; l1 = {}; x = 1; p = 1;
l = Subsets[a, {2}]; l8 = {};
While[x <= Length[l], AppendTo[l1, (l[[x]][[1]]*l[[x]][[2]])]; x++]


func[k_] :=
StringReplace[ToString[Take[l1, {k, k}]], {"{" -> "", "}" -> ""}]

f1[y_] := StringTake[func[y], {1, 1}] == StringTake[func[y], {6, 6}]
f2[y_] := StringTake[func[y], {2, 2}] == StringTake[func[y], {5, 5}]
f3[y_] := StringTake[func[y], {3, 3}] == StringTake[func[y], {4, 4}]
f4[y_] := f1[y] || f2[y] || f3[y]


While[p <= Length[l1],
If[f4[p] == True, AppendTo[l8, l1[[p]]], AppendTo[l8, False]]; p++]


This is suposed to generate the multiples of (800*800), (800*801), (...*...), (999*999), I guess the problem is on the detached mid, I made that functions to check If the number in question is a palindromic number but it gives me 701600 as a palindromic number. Something is wrong but I can't see where. Can you help me?

EDIT: Ok, it's solved, you can check here, I've also made two plots on the distribution of the palindromic numbers. I just did it again and used Fx's advice.

-
When you limit your search to six-digit numbers they will look like abccba and therefore must be multiples of 11, whence at least one of the factors is a multiple of 11. This can readily be exploited to speed up the solution by an order of magnitude :-). If you focus optimistically on the numbers of the form 9bccb9, then both factors must be odd, further reducing the effort by 75%. Considering they must also exceed 900 and screening the results modulo 10, you can do this problem with pencil and paper in just a few minutes... – whuber Sep 2 '12 at 18:37

The logical operators in f4 need to be && (logical and), not || (logical or):

f4[y_] := f1[y] && f2[y] && f3[y]

-
Yep. I just probed with 1 == 1 || 1 == 1 || 1 == 0 and it gave me True. – Voyska Aug 27 '12 at 21:19
Even with f4[y_] := f1[y] && f2[y] && f3[y]it still give me a number which is not palindromic, such as 701600. – Voyska Aug 27 '12 at 21:24
@GustavoBandeira I kindly suggest you accept a more complete answer below, rather than mine :) – F'x Aug 28 '12 at 12:39
Yep, but your answer was more helpful to me because I've already had something done - yours was a fix on what I was doing. These guys answers are GREAT, indeed. But I couldn't implement or understand because I still don't know how to use Mathematica properly. Their answers are going to be VERY useful in the near future, because I'm reading : "Mathematica programming: an advanced introduction" from Leonid Schifrin. – Voyska Aug 28 '12 at 12:44

You can skip the whole string thing and use IntegerDigits to check if it is palindromic. If I'm interpreting what you are doing right, you just can create l8 as so:

l8 = l1 /. k_Integer /; Reverse[IntegerDigits[k]] != IntegerDigits[k] -> False


Or if you just want the palindromic ones by themselves:

Pick[l1, Reverse[IntegerDigits[#]] == IntegerDigits[#] & /@ l1]


Also,

l1 = Times @@@ l


is a bit nicer than a While loop.

-
Strings are generally a bit faster especially if it's a large integer, so I would go with your earlier comment (now removed) and use StringReverse along with IntegerString – R. M. Aug 27 '12 at 22:14

Very bruteforcing, but some beauty in it :)

NestWhileList[
FindInstance[
a b == Array[10^#&, 6, 0].{p,l,k,k,l,p} &&
a b > (a b /. #[[1]])                   &&
And@@ (100 <= # < 1000 & /@ {a,b})      &&
And@@ (  0 <= # <= 9   & /@ {l,k,p}),
{l,k,p,a,b}, Integers] &,
{{a->100,b->100}}, # != {} &]

-

There's something to be said about successive filtering; it's still brute force, but you can keep using finer filters at each stage:

pals = Cases[Range[800 800, 999 999], n_ /; ((# === StringReverse[#]) &[IntegerString[n]])];

c1 = Cases[pals, n_ /; Count[Divisors[n], d_ /; IntegerLength[d] == 3] >= 2];

Cases[c1, n_ /; n == Times @@ Take[Cases[Divisors[n], d_ /; IntegerLength[d] == 3], -2]]

{642246, 648846, 649946, 652256, 653356, 656656, 657756, 660066,
661166, 663366, 672276, 675576, 678876, 689986, 693396, 723327,
729927, 737737, 747747, 749947, 770077, 780087, 793397, 801108,
802208, 804408, 807708, 809908, 819918, 821128, 824428, 840048,
853358, 855558, 861168, 886688, 888888, 906609}

-

Here's a succinct solution that finds the largest palindrome:

Outer[(#1 #2 // IntegerDigits // If[# == Reverse[#], FromDigits[#], 0] &) &,
Range[100, 999], Range[100, 999]] // Max


I have ignored the fact that Times is Orderless in order to optimise for readability rather than speed.

-
palindromicQ = Reverse[IntegerDigits[#]] === IntegerDigits[#] &;
threeDigitDivs = Intersection[Range[100, 999], Divisors[#]] &;
Select[Range[999999, 10000, -1],
And[palindromicQ[#],
Intersection[threeDigitDivs[#], #/threeDigitDivs[#]] =!= {}] &, 1]
(* {906 609} *)

Select[Range[999999, 10000, -1],
And[palindromicQ[#],
Intersection[threeDigitDivs[#], #/threeDigitDivs[#]] =!= {}] &, 10]
(* {906609, 888888, 886688, 861168, 855558, 853358, 840048, 828828, 824428, 821128} *)


Update: As usual, Pick with appropriate selector array is much faster than Select to generate all 655 numbers:

 palPrdctsOf3DigitNums = With[{
palindromes = Pick[Range[10000, 1000000],
Boole[Reverse[IntegerDigits[#]] == IntegerDigits[#]] & /@
Range[10000, 1000000], 1],
threedigitDivisors =
Function[{p}, Intersection[Range[100, 999], Divisors[p]]]},
Pick[palindromes,
Boole[
Intersection[
threedigitDivisors[#], #/threedigitDivisors[#]] =!= {}] &
/@ palindromes, 1]]; // Timing
(* {0.64, Null} *)
(* MMA V 8.0.4.0  MS Windows Vista 64-bit Intel Core Duo2 T9600 @ 2.8GHz with 8G memory *)

ListPlot[Tooltip /@ palPrdctsOf3DigitNums]


Update 2: Yet another brute force enumeration:

 DeleteDuplicates@
Pick[#, Boole[Reverse[IntegerDigits[#]] == IntegerDigits[#]] & /@ #,1] &
@(Times @@@ (Flatten[Table[{i, j}, {i, 100, 999}, {j, i, 999}], 1])) //
Length // Timing
(* {0.593, 655} *)

-

Might be easier to start with palindromes, then see which have appropriate factors. This will be fast as long as we are in a size range where Divisors[] is fast.

palproduct[n_] := Catch[Module[
{mult = 10^n, mminus1 = 10^n - 1, mover10 = 10^(n - 1), j, pal,
divs},
For[j = mminus1, j >= mover10, j--,
pal = mult*j + FromDigits[Reverse[IntegerDigits[j]]];
divs =
Select[Divisors[pal],
mminus1 >= # >= j && mminus1 >= pal/# >= mover10 &];
If[divs =!= {}, Throw[{pal, First[divs], pal/First[divs]}]]
]
]]

Table[Timing[palproduct[m]], {m, 2, 9}]

(*
{{0.01500000000010004, {9009, 91, 99}}, {0., {906609, 913,
993}}, {0., {99000099, 9901,
9999}}, {0.04699999999979809, {9966006699, 99681,
99979}}, {0.2810000000001764, {999000000999, 999001,
999999}}, {1.90300000000002, {99956644665999, 9997647,
9998017}}, {6.286999999999807, {9999000000009999, 99990001,
99999999}}, {86.5490000000002, {999900665566009999, 999920317,
999980347}}}
*)

-

A fairly straightforward solution employing string manipulation (similar to IntegerDigits):

Last[
Select[
Union[Flatten[Table[i*j, {i, 100, 999}, {j, 100, 999}]]],
# === ToExpression[StringReverse[ToString[#]]] &]]

-

A fast method:

   Intersection[
1000 # + FromDigits@Reverse@IntegerDigits[#] & /@ Range[100, 999],
Join @@ Outer[Times,  Range[100, 999], Range[110, 990, 11]]] //
Max // Timing


or

ok[n_] :=
MemberQ[IntegerLength[
Table[#[[{i, -i}]], {i, 2, Length[#]/2}] &[Divisors[n]]], {3, 3}];
Select[Flatten@
Table[100001 i + 10010 j + 1100 k, {i, 9}, {j, 0, 9}, {k, 0, 9}], ok] // Max // Timing
`
-