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

Question

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 02 '12 at 18:37

wxffles · Answer 1 · 2012-08-27T22:14:07.247

10

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.

edited Aug 27 '12 at 22:14

answered Aug 27 '12 at 22:06

wxffles

14,246
1
43
75

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 – rm -rf Aug 27 '12 at 22:14

Dr. belisarius · Answer 2 · 2012-08-28T04:01:55.883

10

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}}, # != {} &]

edited Aug 28 '12 at 04:01

answered Aug 27 '12 at 23:44

Dr. belisarius

115,881
13
203
453

score 7 · Answer 3 · answered Sep 02 '12 at 15:35

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}}}
*)

score 7 · Accepted Answer · answered Aug 27 '12 at 21:16

7

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

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

answered Aug 27 '12 at 21:16

F'x

10,817
3
52
92

Yep. I just probed with 1 == 1 || 1 == 1 || 1 == 0 and it gave me True. – Red Banana 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. – Red Banana Aug 27 '12 at 21:24
1

@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. – Red Banana Aug 28 '12 at 12:44

kglr · Answer 5 · 2012-08-28T11:47:46.007

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]

enter image description here

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} *)

score 7 · Answer 6 · answered Aug 28 '12 at 05:23

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}

score 7 · Answer 7 · answered Aug 28 '12 at 10:00

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.

bmf · Answer 8 · 2022-04-27T15:23:33.117

This is a report on an upgrade in later versions. Things changed for the best with regards to this question. Since V10.3 we have PalindromeQ.

We start by considering

a = Range[800, 999];

and then we create (800*800), (800*801),...,(999*999) like so:

data = Union @@ Outer[Times, a, a];

We run

Grid@Partition[MatrixForm /@ Select[data, PalindromeQ], 7]

And if we just want the largest one, following the statement of the problem,

Last@Select[data, PalindromeQ]

score 3 · Answer 9 · answered Nov 20 '12 at 11:46

3

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[#]]] &]]

answered Nov 20 '12 at 11:46

geordie

3,693
1
26
33

chyanog · Answer 10 · 2013-02-01T13:47:43.690

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

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

10 Answers10

Linked

Related