Dive into Project Euler Part 5 (81-100)

Problem 81

1
2
3
4
5
6
7
8
9
s = Import["p081_matrix.txt", "Data"];
Clear@MinPathSum;
MinPathSum[1, 1] := s[[1, 1]]
MinPathSum[r_, c_] := MinPathSum[r, c] =
   If[r == 1, MinPathSum[r, c - 1],
     If[c == 1, MinPathSum[r - 1, c],
      Min[MinPathSum[r - 1, c], MinPathSum[r, c - 1]]]] + s[[r, c]];
MinPathSum[80, 80]
427337

Dive into Project Euler Part 4 (61-80)

Problem 61

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
LEN=6
numbers=[[] for row in range(LEN)]
solution=[0]*LEN
for i in range(200):
    if(1000<=i*(i+1)/2<10000):
        numbers[0].append(int(i*(i+1)/2))
    if(1000<=i*i<10000):
        numbers[1].append(i*i)
    if(1000<=i*(3*i-1)/2<10000):
        numbers[2].append(int(i*(3*i-1)/2))
    if(1000<=i*(2*i-1)<10000):
        numbers[3].append(i*(2*i-1))           
    if(1000<=i*(5*i-3)/2<10000):
        numbers[4].append(int(i*(5*i-3)/2))
    if(1000<=i*(3*i-2)<10000):
        numbers[5].append(i*(3*i-2))
 
def FindNext(last, length):
    for i in range(LEN):
        if (solution[i] == 0):
            for j in range(len(numbers[i])):
                if(numbers[i][j] not in solution and ((numbers[i][j] // 100) == (solution[last] % 100))):
                    solution[i] = numbers[i][j]
                    if (length == 5):
                        if (solution[5] // 100 == solution[i] % 100):
                            return True
                    elif (FindNext(i, length + 1)):
                        return True
 
            solution[i] = 0  #backforce
    return  False
 
for i in range(len(numbers[5])):
    solution[5]=numbers[5][i]
    if(FindNext(5, 1)):       
        print(solution, sum(solution))
        break

[8256, 5625, 2882, 8128, 2512, 1281] 28684

Dive into Project Euler Part 3 (41-60)

Problem 41

1
2
Max@Table[ Select[FromDigits /@ Permutations[Range[i]], PrimeQ], {i, 9}]
7652413

Problem 42

1
2
3
4
5
6
s = (Total[ToCharacterCode[#] - First@ToCharacterCode["A"] + 1]) & /@ StringSplit[StringReplace[Import["R:\\words.txt"], "\"" -> ""],   ","];
Reduce[n*(n + 1)/2 >Max[s] && n > 0, n, Integers]
n >= 20
In[37]:= tn = Array[#*(# + 1)/2 &, 20];
In[38]:= Select[s, MemberQ[tn, #] &] // Length
Out[38]= 162

Problem 43

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
cf = With[{
    code =
     And @@ Thread[
         Table[100 A[[i]] + 10 A[[i + 1]] + A[[i + 2]], {i, 2, 8}]~
           Mod~{2, 3, 5, 7, 11, 13, 17} == 0] // Boole // Quiet
    },
   Compile[{ {A, _Integer, 1} },
    code,
    RuntimeAttributes -> Listable,
    RuntimeOptions -> "Speed", CompilationTarget -> "C"
    ]
   ];
FromDigits /@ Pick[#, cf@#, 1] &@Permutations@Range[0, 9] // Tr
16695334890

Dive into Project Euler Part 2 (21-40)

Problem 21

1
2
3
f = DivisorSigma[1, #] - # &;
Total@Select[Range[9999], (a = f@#; a < 9999 && a != # && f@a == #) &]
31626

Problem 22

1
2
3
nl=Sort@StringSplit[StringReplace[Import["p022_names.txt"], "\"" -> ""], ","];
Total@MapIndexed[Total[ToCharacterCode[#1] - First[ToCharacterCode["A"]] + 1] * First[#2] &, nl]
871198282

Problem 23

1
2
3
4
Abundants = Select[Range[1, 28123], DivisorSigma[1, #] - # > # &];
Total@Complement[Range[1, 28123],
  DeleteDuplicates@(   (Abundants[[#]] + Abundants[[# ;; -1]]) & /@ Range[Length@Abundants] // Flatten  )]
4179871

Problem 24

1
2
FromDigits[Permutations[Range[0, 9], {10}][[1*^6]]]
2783915460

Problem 25

1
2
NestWhile[(# + 1) &, 1, IntegerLength@Fibonacci@# < 1000 &]
4782

Dive into Project Euler Part 1 (1-20)

Although calculation of mathematica codes could be slower than those written in C/C++, or even those in python, the prodigious and interesting if not funny functions do save coding time a lot.

Problem 1

Brute force solution at first thought:

1
2
Total@Select[Range[999], 3\[Divides]# || 5\[Divides]# &]
233168

What if the upper limit is extreme large, like \(10^{10}\), or \(10^{10^7}\)? Calculating one after another or even saving them using Range is impossible. Here comes the mathematical way:

1
2
3
4
5
top = 10^(10^7) - 1;
SumMultiplesOf[n_] := (p = Quotient[top, n]; n*p*(p + 1)/2);
SumMultiplesOf[m_, n_] := SumMultiplesOf[m] + SumMultiplesOf[n] - SumMultiplesOf[LCM[m, n]];
N[SumMultiplesOf[3, 5], 2] // AbsoluteTiming
{2.222280, 2.3*10^19999999}

Problem 2

1
2
3
n=NestWhile[# + 1 &, 1, Fibonacci@# <= 4*^6 &] - 1
Total@Select[Array[Fibonacci,n] ,  EvenQ]
4613732

Even numbers appear every 3rd positions in Fibonacci series:

1
Total@Table[Fibonacci@i, {i, 3, n, 3}]

Problem 3

1
2
Max[FactorInteger[600851475143][[All, 1]]]
6857

Problem 4

1
2
Catch@Scan[If[FromDigit@Reverse@IntegerDigits@# == #, Throw[#]] &, Reverse@Sort@Flatten@Table[i*j, {i, 999, 100, -1}, {j, i, 100, -1}]]
906609

Problem 5

1
2
LCM @@ Range[20]
232792560