Difference between revisions of "Euler problems/21 to 30"
(→Problem 21: Clarify problem and add a solution.) 

(45 intermediate revisions by 20 users not shown)  
Line 1:  Line 1:  
−  [[Category:Programming exercise spoilers]] 

+  == [http://projecteuler.net/index.php?section=problems&id=21 Problem 21] == 

−  == [http://projecteuler.net/index.php?section=view&id=21 Problem 21] == 

+  Evaluate the sum of all amicable numbers (including those with a pair number over the limit) under 10000. 

−  Evaluate the sum of all amicable pairs under 10000. 

+  
+  Solution: 

+  (http://www.research.att.com/~njas/sequences/A063990) 

−  Solution: 

This is a little slow because of the naive method used to compute the divisors. 
This is a little slow because of the naive method used to compute the divisors. 

<haskell> 
<haskell> 

Line 13:  Line 14:  
</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=22 Problem 22] == 

+  Here is an alternative using a faster way of computing the sum of divisors. 

−  What is the total of all the name scores in the file of first names? 

−  
−  Solution: 

<haskell> 
<haskell> 

−   apply to a list of names 

+  problem_21_v2 = sum [n  n < [2..9999], let m = d n, 

−  problem_22 :: [String] > Int 

+  m > 1, m < 10000, n == d m, d m /= d (d m)] 

−  problem_22 = sum . zipWith (*) [ 1 .. ] . map score 

+  d n = product [(p * product g  1) `div` (p  1)  

−  where score = sum . map ( subtract 64 . ord ) 

+  g < group $ primeFactors n, let p = head g 

+  ]  n 

+  primeFactors = pf primes 

+  where 

+  pf ps@(p:ps') n 

+   p * p > n = [n] 

+   r == 0 = p : pf ps q 

+   otherwise = pf ps' n 

+  where (q, r) = n `divMod` p 

+  primes = 2 : filter (null . tail . primeFactors) [3,5..] 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=23 Problem 23] == 

+  Here is another alternative solution that computes the sumofdivisors for the numbers by iterating over products of their factors (very fast): 

−  Find the sum of all the positive integers which cannot be written as the sum of two abundant numbers. 

−  Solution: 

<haskell> 
<haskell> 

−  module Main where 

+  import Data.Array 

−  import Data.Set hiding (filter) 

+  max_ = 100000 

−  main :: IO () 

+  gen 100001 = [] 

−  main = do 

+  gen n = [(i*n,n)i < [2 .. max_ `div` n]] ++ (gen (n+1)) 

−  print $ sum [1..28123]  (fold (+) 0 $ abundant_sums $ abundant 28123) 

−  abundant_sums :: [Integer] > Set Integer 

+  arr = accumArray (+) 0 (0,max_) (gen 1) 

−  abundant_sums [] = empty 

−  abundant_sums l@(x:xs) = union (fromList [x + a  a < takeWhile (\y > y <= 28123  x) l]) (abundant_sums xs) 

−  factors :: (Integral n) => n > [n] 

+  problem_21_v3 = sum $ filter (\a > let b = (arr!a) in b /= a && (arr!b) == a) [1 .. (10000  1)] 

−  factors 1 = [1] 

−  factors n = [d  d < [1..n `div` 2], n `mod` d == 0] 

−  abundant :: Integer > [Integer] 

−  abundant n = [a  a < [1..n], (sum $ factors a) > a] 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [http://projecteuler.net/index.php?section=problems&id=22 Problem 22] == 
−  What is the 
+  What is the total of all the name scores in the file of first names? 
Solution: 
Solution: 

<haskell> 
<haskell> 

−  perms [] = [[]] 

+  import Data.List 

−  perms xs = do 

+  import Data.Char 

−  x < xs 

+  problem_22 = 

−  map ( x: ) ( perms . delete x $ xs ) 

+  do input < readFile "names.txt" 

−  
+  let names = sort $ read$"["++ input++"]" 

−  problem_24 = ( perms "0123456789" ) !! 999999 

+  let scores = zipWith score names [1..] 

+  print . sum $ scores 

+  where score w i = (i *) . sum . map (\c > ord c  ord 'A' + 1) $ w 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [http://projecteuler.net/index.php?section=problems&id=23 Problem 23] == 
−  +  Find the sum of all the positive integers which cannot be written as the sum of two abundant numbers. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  valid ( i, n ) = length ( show n ) == 1000 

+  http://www.research.att.com/~njas/sequences/A048242 

+  import Data.Array 

+  n = 28124 

+  abundant n = eulerTotient n  n > n 

+  abunds_array = listArray (1,n) $ map abundant [1..n] 

+  abunds = filter (abunds_array !) [1..n] 

−  problem_25 = fst . head . filter valid . zip [ 1 .. ] $ fibs 

+  rests x = map (x) $ takeWhile (<= x `div` 2) abunds 

−  where fibs = 1 : 1 : 2 : zipWith (+) fibs ( tail fibs ) 

+  isSum = any (abunds_array !) . rests 

+  
+  problem_23 = print . sum . filter (not . isSum) $ [1..n] 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [http://projecteuler.net/index.php?section=problems&id=24 Problem 24] == 
−  +  What is the millionth lexicographic permutation of the digits 0, 1, 2, 3, 4, 5, 6, 7, 8 and 9? 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_26 = fst $ maximumBy (\a b > snd a `compare` snd b) 

+  import Data.List 

−  [(n,recurringCycle n)  n < [1..999]] 

+  
−  where recurringCycle d = remainders d 10 [] 

+  fac 0 = 1 

−  remainders d 0 rs = 0 

+  fac n = n * fac (n  1) 

−  remainders d r rs = let r' = r `mod` d 

+  perms [] _= [] 

−  in case findIndex (== r') rs of 

+  perms xs n= x : perms (delete x xs) (mod n m) 

−  Just i > i + 1 

+  where m = fac $ length xs  1 

−  Nothing > remainders d (10*r') (r':rs) 

+  y = div n m 

+  x = xs!!y 

+  
+  problem_24 = perms "0123456789" 999999 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=27 Problem 27] == 

+  Or, using Data.List.permutations, 

−  Find a quadratic formula that produces the maximum number of primes for consecutive values of n. 

+  <haskell> 

+  import Data.List 

+  problem_24 = (!! 999999) . sort $ permutations ['0'..'9'] 

+  </haskell> 

−  Solution: 

+  Casey Hawthorne 

+  
+  For Project Euler #24 you don't need to generate all the lexicographic permutations by Knuth's method or any other. 

+  
+  You're only looking for the millionth lexicographic permutation of "0123456789" 

−  The following is written in [http://haskell.org/haskellwiki/Literate_programming#Haskell_and_literate_programming literate Haskell]: 

<haskell> 
<haskell> 

−  > import Data.List 

−  To be sure we get the maximum type checking of the compiler, 

+   Plan of attack. 

−  we switch off the default type 

−  > default () 

+   The "x"s are different numbers 

+   0xxxxxxxxx represents 9! = 362880 permutations/numbers 

+   1xxxxxxxxx represents 9! = 362880 permutations/numbers 

+   2xxxxxxxxx represents 9! = 362880 permutations/numbers 

−  Generate a list of primes. 

−  It works by filtering out numbers that are 

−  divisable by a previously found prime 

−  > primes :: [Int] 

+   20xxxxxxxx represents 8! = 40320 

−  > primes = sieve (2 : [3, 5..]) 

+   21xxxxxxxx represents 8! = 40320 

−  > where 

−  > sieve (p:xs) = p : sieve (filter (\x > x `mod` p > 0) xs) 

−  > isPrime :: Int > Bool 

+   23xxxxxxxx represents 8! = 40320 

−  > isPrime x = x `elem` (takeWhile (<= x) primes) 

+   24xxxxxxxx represents 8! = 40320 

+   25xxxxxxxx represents 8! = 40320 

+   26xxxxxxxx represents 8! = 40320 

+   27xxxxxxxx represents 8! = 40320 

−  The lists of values we are going to try for a and b; 

+  module Euler where 

−  b must be a prime, as n² + an + b is equal to b when n = 0 

−  > testRangeA :: [Int] 

+  import Data.List 

−  > testRangeA = [1000 .. 1000] 

−  > testRangeB :: [Int] 

+  factorial n = product [1..n] 

−  > testRangeB = takeWhile (< 1000) primes 

+   lexOrder "0123456789" 1000000 "" 

−  The search 

+  lexOrder digits left s 

+   len == 0 = s ++ digits 

+   quot > 0 && rem == 0 = lexOrder (digits\\(show (digits!!(quot1)))) rem (s ++ [(digits!!(quot1))]) 

+   quot == 0 && rem == 0 = lexOrder (digits\\(show (digits!!len))) rem (s ++ [(digits!!len)]) 

+   rem == 0 = lexOrder (digits\\(show (digits!!(quot+1)))) rem (s ++ [(digits!!(quot+1))]) 

+   otherwise = lexOrder (digits\\(show (digits!!(quot)))) rem (s ++ [(digits!!(quot))]) 

+  where 

+  len = (length digits)  1 

+  (quot,rem) = quotRem left (factorial len) 

−  > bestCoefficients :: (Int, Int, Int) 

+  </haskell> 

−  > bestCoefficients = 

−  > maximumBy (\(x, _, _) (y, _, _) > compare x y) $ 

−  > [f a b  a < testRangeA, b < testRangeB] 

−  > where 

−  Generate a list of results of the quadratic formula 

+  == [http://projecteuler.net/index.php?section=problems&id=25 Problem 25] == 

−  (only the contiguous primes) 

+  What is the first term in the Fibonacci sequence to contain 1000 digits? 

−  wrap the result in a triple, together with a and b 

−  > f :: Int > Int > (Int, Int, Int) 

+  Solution: 

−  > f a b = ( length $ contiguousPrimes a b 

+  <haskell> 

−  > , a 

+  fibs = 0:1:(zipWith (+) fibs (tail fibs)) 

−  > , b 

+  t = 10^999 

−  > ) 

−  > contiguousPrimes :: Int > Int > [Int] 

+  problem_25 = length w 

−  > contiguousPrimes a b = takeWhile isPrime (map (quadratic a b) [0..]) 

+  where 

+  w = takeWhile (< t) fibs 

+  </haskell> 

−  The quadratic formula 

+  Casey Hawthorne 

−  > quadratic :: Int > Int > Int > Int 

+  I believe you mean the following: 

−  > quadratic a b n = n * n + a * n + b 

+  <haskell> 

−  > problem_27 = 

+  fibs = 0:1:(zipWith (+) fibs (tail fibs)) 

−  > do 

−  > let (l, a, b) = bestCoefficients 

−  > 

−  > putStrLn $ "" 

−  > putStrLn $ "Problem Euler 27" 

−  > putStrLn $ "" 

−  > putStrLn $ "The best quadratic formula found is:" 

−  > putStrLn $ " n * n + " ++ show a ++ " * n + " ++ show b 

−  > putStrLn $ "" 

−  > putStrLn $ "The number of primes is: " ++ (show l) 

−  > putStrLn $ "" 

−  > putStrLn $ "The primes are:" 

−  > print $ take l $ contiguousPrimes a b 

−  > putStrLn $ "" 

+  last (takeWhile (<10^1000) fibs) 

+  </haskell> 

+  == [http://projecteuler.net/index.php?section=problems&id=26 Problem 26] == 

+  Find the value of d < 1000 for which 1/d contains the longest recurring cycle. 

+  
+  Solution: 

+  <haskell> 

+  problem_26 = fst $ maximumBy (comparing snd) 

+  [(n,recurringCycle n)  n < [1..999]] 

+  where recurringCycle d = remainders d 10 [] 

+  remainders d 0 rs = 0 

+  remainders d r rs = let r' = r `mod` d 

+  in case elemIndex r' rs of 

+  Just i > i + 1 

+  Nothing > remainders d (10*r') (r':rs) 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [http://projecteuler.net/index.php?section=problems&id=27 Problem 27] == 
−  +  Find a quadratic formula that produces the maximum number of primes for consecutive values of n. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  corners :: Int > (Int, Int, Int, Int) 

+  problem_27 = (2*a1)*(a^2a+41) 

−  corners i = (n*n, 1+(n*(2*m)), 2+(n*(2*m1)), 3+(n*(2*m2))) 

+  where n = 1000 

−  where m = (i1) `div` 2 

+  m = head $ filter (\x>x^2x+41>n) [1..] 

−  +  a = m1 

+  </haskell> 

−  sumcorners :: Int > Int 

+  == [http://projecteuler.net/index.php?section=problems&id=28 Problem 28] == 

−  sumcorners i = a+b+c+d where (a, b, c, d) = corners i 

+  What is the sum of both diagonals in a 1001 by 1001 spiral? 

−  sumdiags :: Int > Int 

+  Solution: 

−  sumdiags i  even i = error "not a spiral" 

+  <haskell> 

−   i == 3 = s + 1 

+  problem_28 = sum (map (\n > 4*(n2)^2+10*(n1)) [3,5..1001]) + 1 

−   otherwise = s + sumdiags (i2) 

+  </haskell> 

−  where s = sumcorners i 

−  problem_28 = sumdiags 1001 

+  Alternatively, one can use the fact that the distance between the diagonal numbers increases by 2 in every concentric square. Each square contains four gaps, so the following <hask>scanl</hask> does the trick: 

+  
+  <haskell> 

+  euler28 n = sum $ scanl (+) 0 

+  (1:(concatMap (replicate 4) [2,4..(n1)])) 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [http://projecteuler.net/index.php?section=problems&id=29 Problem 29] == 
How many distinct terms are in the sequence generated by a<sup>b</sup> for 2 ≤ a ≤ 100 and 2 ≤ b ≤ 100? 
How many distinct terms are in the sequence generated by a<sup>b</sup> for 2 ≤ a ≤ 100 and 2 ≤ b ≤ 100? 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_29 = length . group . sort $ [a^b  a < [2..100], b < [2..100]] 

+  import Control.Monad 

+  problem_29 = length . group . sort $ liftM2 (^) [2..100] [2..100] 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=30 Problem 30] == 

+  We can also solve it in a more naive way, without using Monads, like this: 

+  <haskell> 

+  import List 

+  problem_29 = length $ nub pr29_help 

+  where pr29_help = [z  y < [2..100], 

+  z < lift y] 

+  lift y = map (\x > x^y) [2..100] 

+  </haskell> 

+  
+  Simpler: 

+  
+  <haskell> 

+  import List 

+  problem_29 = length $ nub [x^y  x < [2..100], y < [2..100]] 

+  </haskell> 

+  
+  Instead of using lists, the Set data structure can be used for a significant speed increase: 

+  
+  <haskell> 

+  import Set 

+  problem_29 = size $ fromList [x^y  x < [2..100], y < [2..100]] 

+  </haskell> 

+  
+  == [http://projecteuler.net/index.php?section=problems&id=30 Problem 30] == 

Find the sum of all the numbers that can be written as the sum of fifth powers of their digits. 
Find the sum of all the numbers that can be written as the sum of fifth powers of their digits. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_30 = undefined 

+  import Data.Char (digitToInt) 

−  </haskell> 

+  limit :: Integer 

+  limit = snd $ head $ dropWhile (\(a,b) > a > b) $ zip (map (9^5*) [1..]) (map (10^) [1..]) 

−  [[Category:Tutorials]] 

+  fifth :: Integer > Integer 

−  [[Category:Code]] 

+  fifth = sum . map ((^5) . toInteger . digitToInt) . show 

+  
+  problem_30 :: Integer 

+  problem_30 = sum $ filter (\n > n == fifth n) [2..limit] 

+  </haskell> 
Latest revision as of 15:53, 11 October 2015
Contents
Problem 21
Evaluate the sum of all amicable numbers (including those with a pair number over the limit) under 10000.
Solution: (http://www.research.att.com/~njas/sequences/A063990)
This is a little slow because of the naive method used to compute the divisors.
problem_21 = sum [m+n  m < [2..9999], let n = divisorsSum ! m, amicable m n]
where amicable m n = m < n && n < 10000 && divisorsSum ! n == m
divisorsSum = array (1,9999)
[(i, sum (divisors i))  i < [1..9999]]
divisors n = [j  j < [1..n `div` 2], n `mod` j == 0]
Here is an alternative using a faster way of computing the sum of divisors.
problem_21_v2 = sum [n  n < [2..9999], let m = d n,
m > 1, m < 10000, n == d m, d m /= d (d m)]
d n = product [(p * product g  1) `div` (p  1) 
g < group $ primeFactors n, let p = head g
]  n
primeFactors = pf primes
where
pf ps@(p:ps') n
 p * p > n = [n]
 r == 0 = p : pf ps q
 otherwise = pf ps' n
where (q, r) = n `divMod` p
primes = 2 : filter (null . tail . primeFactors) [3,5..]
Here is another alternative solution that computes the sumofdivisors for the numbers by iterating over products of their factors (very fast):
import Data.Array
max_ = 100000
gen 100001 = []
gen n = [(i*n,n)i < [2 .. max_ `div` n]] ++ (gen (n+1))
arr = accumArray (+) 0 (0,max_) (gen 1)
problem_21_v3 = sum $ filter (\a > let b = (arr!a) in b /= a && (arr!b) == a) [1 .. (10000  1)]
Problem 22
What is the total of all the name scores in the file of first names?
Solution:
import Data.List
import Data.Char
problem_22 =
do input < readFile "names.txt"
let names = sort $ read$"["++ input++"]"
let scores = zipWith score names [1..]
print . sum $ scores
where score w i = (i *) . sum . map (\c > ord c  ord 'A' + 1) $ w
Problem 23
Find the sum of all the positive integers which cannot be written as the sum of two abundant numbers.
Solution:
http://www.research.att.com/~njas/sequences/A048242
import Data.Array
n = 28124
abundant n = eulerTotient n  n > n
abunds_array = listArray (1,n) $ map abundant [1..n]
abunds = filter (abunds_array !) [1..n]
rests x = map (x) $ takeWhile (<= x `div` 2) abunds
isSum = any (abunds_array !) . rests
problem_23 = print . sum . filter (not . isSum) $ [1..n]
Problem 24
What is the millionth lexicographic permutation of the digits 0, 1, 2, 3, 4, 5, 6, 7, 8 and 9?
Solution:
import Data.List
fac 0 = 1
fac n = n * fac (n  1)
perms [] _= []
perms xs n= x : perms (delete x xs) (mod n m)
where m = fac $ length xs  1
y = div n m
x = xs!!y
problem_24 = perms "0123456789" 999999
Or, using Data.List.permutations,
import Data.List
problem_24 = (!! 999999) . sort $ permutations ['0'..'9']
Casey Hawthorne
For Project Euler #24 you don't need to generate all the lexicographic permutations by Knuth's method or any other.
You're only looking for the millionth lexicographic permutation of "0123456789"
 Plan of attack.
 The "x"s are different numbers
 0xxxxxxxxx represents 9! = 362880 permutations/numbers
 1xxxxxxxxx represents 9! = 362880 permutations/numbers
 2xxxxxxxxx represents 9! = 362880 permutations/numbers
 20xxxxxxxx represents 8! = 40320
 21xxxxxxxx represents 8! = 40320
 23xxxxxxxx represents 8! = 40320
 24xxxxxxxx represents 8! = 40320
 25xxxxxxxx represents 8! = 40320
 26xxxxxxxx represents 8! = 40320
 27xxxxxxxx represents 8! = 40320
module Euler where
import Data.List
factorial n = product [1..n]
 lexOrder "0123456789" 1000000 ""
lexOrder digits left s
 len == 0 = s ++ digits
 quot > 0 && rem == 0 = lexOrder (digits\\(show (digits!!(quot1)))) rem (s ++ [(digits!!(quot1))])
 quot == 0 && rem == 0 = lexOrder (digits\\(show (digits!!len))) rem (s ++ [(digits!!len)])
 rem == 0 = lexOrder (digits\\(show (digits!!(quot+1)))) rem (s ++ [(digits!!(quot+1))])
 otherwise = lexOrder (digits\\(show (digits!!(quot)))) rem (s ++ [(digits!!(quot))])
where
len = (length digits)  1
(quot,rem) = quotRem left (factorial len)
Problem 25
What is the first term in the Fibonacci sequence to contain 1000 digits?
Solution:
fibs = 0:1:(zipWith (+) fibs (tail fibs))
t = 10^999
problem_25 = length w
where
w = takeWhile (< t) fibs
Casey Hawthorne
I believe you mean the following:
fibs = 0:1:(zipWith (+) fibs (tail fibs))
last (takeWhile (<10^1000) fibs)
Problem 26
Find the value of d < 1000 for which 1/d contains the longest recurring cycle.
Solution:
problem_26 = fst $ maximumBy (comparing snd)
[(n,recurringCycle n)  n < [1..999]]
where recurringCycle d = remainders d 10 []
remainders d 0 rs = 0
remainders d r rs = let r' = r `mod` d
in case elemIndex r' rs of
Just i > i + 1
Nothing > remainders d (10*r') (r':rs)
Problem 27
Find a quadratic formula that produces the maximum number of primes for consecutive values of n.
Solution:
problem_27 = (2*a1)*(a^2a+41)
where n = 1000
m = head $ filter (\x>x^2x+41>n) [1..]
a = m1
Problem 28
What is the sum of both diagonals in a 1001 by 1001 spiral?
Solution:
problem_28 = sum (map (\n > 4*(n2)^2+10*(n1)) [3,5..1001]) + 1
Alternatively, one can use the fact that the distance between the diagonal numbers increases by 2 in every concentric square. Each square contains four gaps, so the following scanl
does the trick:
euler28 n = sum $ scanl (+) 0
(1:(concatMap (replicate 4) [2,4..(n1)]))
Problem 29
How many distinct terms are in the sequence generated by a^{b} for 2 ≤ a ≤ 100 and 2 ≤ b ≤ 100?
Solution:
import Control.Monad
problem_29 = length . group . sort $ liftM2 (^) [2..100] [2..100]
We can also solve it in a more naive way, without using Monads, like this:
import List
problem_29 = length $ nub pr29_help
where pr29_help = [z  y < [2..100],
z < lift y]
lift y = map (\x > x^y) [2..100]
Simpler:
import List
problem_29 = length $ nub [x^y  x < [2..100], y < [2..100]]
Instead of using lists, the Set data structure can be used for a significant speed increase:
import Set
problem_29 = size $ fromList [x^y  x < [2..100], y < [2..100]]
Problem 30
Find the sum of all the numbers that can be written as the sum of fifth powers of their digits.
Solution:
import Data.Char (digitToInt)
limit :: Integer
limit = snd $ head $ dropWhile (\(a,b) > a > b) $ zip (map (9^5*) [1..]) (map (10^) [1..])
fifth :: Integer > Integer
fifth = sum . map ((^5) . toInteger . digitToInt) . show
problem_30 :: Integer
problem_30 = sum $ filter (\n > n == fifth n) [2..limit]