Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
3  
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
add comment

9 Answers

up vote 5 down vote accepted

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

f4[y_] := f1[y] && f2[y] && f3[y]
share|improve this answer
    
Yep. I just probed with 1 == 1 || 1 == 1 || 1 == 0 and it gave me True. –  Igäria Mnagarka 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. –  Igäria Mnagarka 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. –  Igäria Mnagarka Aug 28 '12 at 12:44
add comment

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
share|improve this answer
add comment

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[#]]] &]]
share|improve this answer
add comment

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}}}
*)
share|improve this answer
add comment
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} *)
share|improve this answer
add comment

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.

share|improve this answer
add comment

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}
share|improve this answer
add comment

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}}, # != {} &]
share|improve this answer
add comment

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.

share|improve this answer
    
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
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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