5
$\begingroup$

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.

Improve this question
$\endgroup$
1
  • 3
    $\begingroup$ 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... $\endgroup$
    – whuber
    Sep 2, 2012 at 18:37

10 Answers 10

Reset to default
7
$\begingroup$

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

f4[y_] := f1[y] && f2[y] && f3[y]
Improve this answer
$\endgroup$
4
  • $\begingroup$ Yep. I just probed with 1 == 1 || 1 == 1 || 1 == 0 and it gave me True. $\endgroup$
    – Red Banana
    Aug 27, 2012 at 21:19
  • $\begingroup$ Even with f4[y_] := f1[y] && f2[y] && f3[y]it still give me a number which is not palindromic, such as 701600. $\endgroup$
    – Red Banana
    Aug 27, 2012 at 21:24
  • 1
    $\begingroup$ @GustavoBandeira I kindly suggest you accept a more complete answer below, rather than mine :) $\endgroup$
    – F'x
    Aug 28, 2012 at 12:39
  • $\begingroup$ 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. $\endgroup$
    – Red Banana
    Aug 28, 2012 at 12:44
10
$\begingroup$

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.

Improve this answer
$\endgroup$
1
  • $\begingroup$ 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 $\endgroup$
    – rm -rf ♦
    Aug 27, 2012 at 22:14
10
$\begingroup$

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}}, # != {} &]
Improve this answer
$\endgroup$
7
$\begingroup$

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}
Improve this answer
$\endgroup$
7
$\begingroup$

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.

Improve this answer
$\endgroup$
7
$\begingroup$ 
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} *)
Improve this answer
$\endgroup$
7
$\begingroup$

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}}}
*)
Improve this answer
$\endgroup$
4
$\begingroup$

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]

gridprime

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

Last@Select[data, PalindromeQ]

last

Improve this answer
$\endgroup$
3
$\begingroup$

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[#]]] &]]
Improve this answer
$\endgroup$
3
$\begingroup$

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
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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