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

Problem 26

1
2

Last@Ordering[Length@RealDigits[1/#][[1, 1]] & /@ Range[999]]
983

Problem 27

1
2
3
4
5
6
7
8

al = Range[-999, 999];
pl = Array[Prime, PrimePi@999];
bl = Join[pl, -pl];
f[a_, b_] := NestWhile[# + 1 &, 0, PrimeQ[#^2 + a # + b] &];
s = Table[f[a, b], {a, al}, {b, bl}];
pos = Position[s, Max[s]];
al[[pos[[1, 1]]]]*bl[[pos[[1, 2]]]]
-59231

Problem 28

1
2

Total@FoldList[Plus, 1, Array[Ceiling[#/4]*2 &, (1001-1)/2*4]]
669171001

Problem 29

1
2

Length@DeleteDuplicates@Flatten@Table[a^b, {a, 2, 100}, {b, 2, 100}]
9183

Problem 30

1
2

Total@Select[Range[10, 1*^6 - 1], # == Total[(IntegerDigits@#)^5] &]
443839

Problem 31

1
2

Length@IntegerPartitions[200, All, {1, 2, 5, 10, 20, 50, 100, 200}]
73682

Problem 32

1
2
3

f[m_List, n_List] :=Select[Flatten[Table[{i, j, i*j}, {i, m}, {j, n}], 1],  Sort@Flatten@IntegerDigits@# == Range[9] &]
Total@DeleteDuplicates@ Join[f[Range[12, 98], Range[123, 987]],  f[Range[1, 9], Range[1234, 9876]]][[All, 3]]
45228

Problem 33

1
2
3
4
5

f[{i_, j_}] :=  Module[{}, {id, jd} = IntegerDigits@{i, j}; c = Intersection[id, jd];
   FreeQ[{id, jd}, 0] && Length@c == 1 &&
 (newi = Delete[id, FirstPosition[id, First@c]]; newj = Delete[jd, FirstPosition[jd, First@c]]; First[newi/newj] == i/j)];
Denominator[Times @@ Divide @@@ Select[Flatten[Table[{i, j}, {i, 10, 98}, {j, i + 1, 99}], 1], f]]
100

Problem 34

1
2
3
4
5
6
7

In[48]:= cf =
  Compile[{ {A, _Integer} },
   Boole[A == Total[Factorial[IntegerDigits[A]]]],
   RuntimeAttributes -> Listable,
   RuntimeOptions -> "Speed", CompilationTarget -> "C"];
n = Range[10, 9!*7];
AbsoluteTiming@Total@Pick[n, cf@n, 1]

Problem 35

1
2
3
4
5
6

cpQ[n_] := 
 AllTrue[FromDigits /@ 
   Array[RotateLeft[IntegerDigits@n, #] &, IntegerLength@n - 1], 
  PrimeQ]
Count[Table[Prime[i], {i, PrimePi[1*^6]}], i_/;cpQ@i]
55

Problem 36

1
2
3

palQ[i_List] := i == Reverse@i;
Total@Select[Range[1*^6], (palQ[IntegerDigits@#] && palQ[IntegerDigits[#, 2]]) &]
872187

Problem 37

1
2
3

TpQ[n_] :=  Module[{l = IntegerDigits@n},  AllTrue[FromDigits /@Flatten[Table[{l[[;; i]], l[[i + 1 ;;]]}, {i, Length@l - 1}], 1],  PrimeQ]];
S = n = 0; i = 5; While[n < 11, a = Prime@i;If[TpQ@a, S += a; ++n]; ++i]; S
748317

Problem 38

1
2
3
4

fl=Select[Range[9123, 9876],Combinatorica`PermutationQ[Catenate@IntegerDigits[{1, 2}*#]] &]
{9267, 9273, 9327}
Max[FromDigits /@ (Catenate@IntegerDigits[{1, 2}*#] & /@fl)]
932718654

Problem 39

1
2
3
4

Commonest@Flatten@Select[# +
      Total[Rest@PowersRepresentations[#^2, 2, 2], {2}] & /@
    Range[500], ListQ]
840

Problem 40

1
2
3
4

i = 0; NestWhileList[(++i; # + i*9*10^(i - 1)) &, 0, # < 1*^6 &]; i
6
Times @@ (Flatten@IntegerDigits@Range[999999])[[Table[ 10^(i - 1), {i, 7}]]]
210