Euler problems/21 to 30
From HaskellWiki
(→Problem 24: Added another method for Problem 24) 

(34 intermediate revisions by 16 users not shown)  
Line 1:  Line 1:  
−  == [http://projecteuler.net/index.php?section=view&id=21 Problem 21] == 
+  == [http://projecteuler.net/index.php?section=problems&id=21 Problem 21] == 
Evaluate the sum of all amicable pairs under 10000. 
Evaluate the sum of all amicable pairs under 10000. 

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

+  
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 15:  Line 15:  
<haskell> 
<haskell> 

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

−  m > 1, m < 10000, n == d m] 
+  m > 1, m < 10000, n == d m, d m /= d (d m)] 
d n = product [(p * product g  1) `div` (p  1)  
d n = product [(p * product g  1) `div` (p  1)  

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

Line 29:  Line 29:  
</haskell> 
</haskell> 

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

Solution: 
Solution: 

<haskell> 
<haskell> 

−   apply to a list of names 
+  import Data.List 
−  problem_22 :: [String] > Int 
+  import Data.Char 
−  problem_22 = sum . zipWith (*) [ 1 .. ] . map score 
+  problem_22 = 
−  where score = sum . map ( subtract 64 . ord ) 
+  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 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=23 Problem 23] == 
+  == [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. 
Find the sum of all the positive integers which cannot be written as the sum of two abundant numbers. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  import Data.List 
+  http://www.research.att.com/~njas/sequences/A048242 
−   An other interesting fact is that every even number not in 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 26, 28, 34, 46 can be expressed as the sum of two abundant numbers. For odd numbers this question is a little bit more tricky. 
+  import Data.Array 
−   http://wwwmaths.swan.ac.uk/pgrads/bb/project/node25.html 
+  n = 28124 
−  notEven=[2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 26, 28, 34, 46] 
+  abundant n = eulerTotient n  n > n 
−  problem_23 = 1 +sum notEven +sum notOdd 
+  abunds_array = listArray (1,n) $ map abundant [1..n] 
−  +  abunds = filter (abunds_array !) [1..n] 

−  abundant :: Integer > [Integer] 

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

−  oddAbu=abundant 28123 

−  canExp x =take 1 [(b,y)b<oddAbu,let y=xb,y>1,(sum$factors y)y>y ] 

−  notOdd=[xx<[3,5..28123],canExp x ==[]] 

−  primes :: [Integer] 

−  primes = 2 : filter ((==1) . length . primeFactors) [3,5..] 

−  
−  primeFactors :: Integer > [Integer] 

−  primeFactors n = factor n primes 

−  where 

−  factor _ [] = [] 

−  factor m (p:ps)  p*p > m = [m] 

−   m `mod` p == 0 = p : factor (m `div` p) (p:ps) 

−   otherwise = factor m ps 

−  
−  factors :: Integer > [Integer] 

−  factors = perms . map (tail . scanl (*) 1) . group . primeFactors 

−  where 

−  perms :: (Integral a) => [[a]] > [a] 

−  perms [] = [1] 

−  perms (x:xs) = perms xs ++ concatMap (\z > map (*z) $ perms xs) x 

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

+  isSum = any (abunds_array !) . rests 

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

</haskell> 
</haskell> 

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

Solution: 
Solution: 

<haskell> 
<haskell> 

+  import Data.List 

+  
+  fac 0 = 1 

+  fac n = n * fac (n  1) 

perms [] _= [] 
perms [] _= [] 

−  perms xs n= do 
+  perms xs n= x : perms (delete x xs) (mod n m) 
−  let m=fac$(length(xs) 1) 
+  where m = fac $ length xs  1 
−  let y=div n m 
+  y = div n m 
−  let x = xs!!y 
+  x = xs!!y 
−  x:( perms ( delete x $ xs ) (mod n m)) 
+  
−  +  problem_24 = perms "0123456789" 999999 

−  problem_24 = perms "0123456789" 999999 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=25 Problem 25] == 
+  Or, using Data.List.permutations, 
−  What is the first term in the Fibonacci sequence to contain 1000 digits? 

−  
−  Solution: 

<haskell> 
<haskell> 

−  valid ( i, n ) = length ( show n ) == 1000 
+  import Data.List 
−  +  problem_24 = (!! 999999) . sort $ permutations ['0'..'9'] 

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

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

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=26 Problem 26] == 
+  Casey Hawthorne 
−  Find the value of d < 1000 for which 1/d contains the longest recurring cycle. 
+  
+  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" 

−  Solution: 

<haskell> 
<haskell> 

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

−  [(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 findIndex (== r') rs of 

−  Just i > i + 1 

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

−  </haskell> 

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

−  Solution: 
+   The "x"s are different numbers 
+   0xxxxxxxxx represents 9! = 362880 permutations/numbers 

+   1xxxxxxxxx represents 9! = 362880 permutations/numbers 

+   2xxxxxxxxx represents 9! = 362880 permutations/numbers 

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

−  <haskell> 

−  > import Data.List 

−  To be sure we get the maximum type checking of the compiler, 
+   20xxxxxxxx represents 8! = 40320 
−  we switch off the default type 
+   21xxxxxxxx represents 8! = 40320 
−  > default () 
+   23xxxxxxxx represents 8! = 40320 
+   24xxxxxxxx represents 8! = 40320 

+   25xxxxxxxx represents 8! = 40320 

+   26xxxxxxxx represents 8! = 40320 

+   27xxxxxxxx represents 8! = 40320 

−  Generate a list of primes. 

−  It works by filtering out numbers that are 

−  divisable by a previously found prime 

−  > primes :: [Int] 
+  module Euler where 
−  > primes = sieve (2 : [3, 5..]) 

−  > where 

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

−  > isPrime :: Int > Bool 
+  import Data.List 
−  > isPrime x = x `elem` (takeWhile (<= x) primes) 

+  factorial n = product [1..n] 

−  The lists of values we are going to try for a and b; 
+   lexOrder "0123456789" 1000000 "" 
−  b must be a prime, as n² + an + b is equal to b when n = 0 

−  > testRangeA :: [Int] 
+  lexOrder digits left s 
−  > testRangeA = [1000 .. 1000] 
+   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) 

−  > testRangeB :: [Int] 
+  </haskell> 
−  > testRangeB = takeWhile (< 1000) primes 

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

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

−  The search 
+  Solution: 
+  <haskell> 

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

+  t = 10^999 

−  > bestCoefficients :: (Int, Int, Int) 
+  problem_25 = length w 
−  > bestCoefficients = 
+  where 
−  > maximumBy (\(x, _, _) (y, _, _) > compare x y) $ 
+  w = takeWhile (< t) fibs 
−  > [f a b  a < testRangeA, b < testRangeB] 
+  </haskell> 
−  > where 

−  Generate a list of results of the quadratic formula 

−  (only the contiguous primes) 

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

−  > f :: Int > Int > (Int, Int, Int) 
+  Casey Hawthorne 
−  > f a b = ( length $ contiguousPrimes a b 

−  > , a 

−  > , b 

−  > ) 

−  > contiguousPrimes :: Int > Int > [Int] 
+  I believe you mean the following: 
−  > contiguousPrimes a b = takeWhile isPrime (map (quadratic a b) [0..]) 

+  <haskell> 

−  The quadratic formula 
+  fibs = 0:1:(zipWith (+) fibs (tail fibs)) 
−  > quadratic :: Int > Int > Int > Int 
+  last (takeWhile (<10^1000) fibs) 
−  > quadratic a b n = n * n + a * n + b 
+  </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. 

−  > problem_27 = 
+  Solution: 
−  > do 
+  <haskell> 
−  > let (l, a, b) = bestCoefficients 
+  problem_26 = fst $ maximumBy (comparing snd) 
−  > 
+  [(n,recurringCycle n)  n < [1..999]] 
−  > putStrLn $ "" 
+  where recurringCycle d = remainders d 10 [] 
−  > putStrLn $ "Problem Euler 27" 
+  remainders d 0 rs = 0 
−  > putStrLn $ "" 
+  remainders d r rs = let r' = r `mod` d 
−  > putStrLn $ "The best quadratic formula found is:" 
+  in case elemIndex r' rs of 
−  > putStrLn $ " n * n + " ++ show a ++ " * n + " ++ show b 
+  Just i > i + 1 
−  > putStrLn $ "" 
+  Nothing > remainders d (10*r') (r':rs) 
−  > putStrLn $ "The number of primes is: " ++ (show l) 
+  </haskell> 
−  > putStrLn $ "" 

−  > putStrLn $ "The primes are:" 

−  > print $ take l $ contiguousPrimes a b 

−  > putStrLn $ "" 

+  == [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: 

+  <haskell> 

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

+  where n = 1000 

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

+  a = m1 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=28 Problem 28] == 
+  == [http://projecteuler.net/index.php?section=problems&id=28 Problem 28] == 
What is the sum of both diagonals in a 1001 by 1001 spiral? 
What is the sum of both diagonals in a 1001 by 1001 spiral? 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  corners :: Int > (Int, Int, Int, Int) 
+  problem_28 = sum (map (\n > 4*(n2)^2+10*(n1)) [3,5..1001]) + 1 
−  corners i = (n*n, 1+(n*(2*m)), 2+(n*(2*m1)), 3+(n*(2*m2))) 
+  </haskell> 
−  where m = (i1) `div` 2 

−  n = 2*m+1 

−  sumcorners :: Int > Int 
+  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: 
−  sumcorners i = a+b+c+d where (a, b, c, d) = corners i 

−  sumdiags :: Int > Int 
+  <haskell> 
−  sumdiags i  even i = error "not a spiral" 
+  euler28 n = sum $ scanl (+) 0 
−   i == 3 = s + 1 
+  (1:(concatMap (replicate 4) [2,4..(n1)])) 
−   otherwise = s + sumdiags (i2) 

−  where s = sumcorners i 

−  
−  problem_28 = sumdiags 1001 

</haskell> 
</haskell> 

−  You can note that from 1 to 3 there's (+2), and such too for 5, 7 and 9, it then goes up to (+4) 4 times, and so on, adding 2 to the number to add for each level of the spiral. You can so avoid all need for multiplications and just do additions with the following code : 
+  == [http://projecteuler.net/index.php?section=problems&id=29 Problem 29] == 
−  <haskell>problem_28 = sum . scanl (+) 1 . concatMap (replicate 4) $ [2,4..1000]</haskell> 

−  
−  == [http://projecteuler.net/index.php?section=view&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> 

+  
+  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> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=30 Problem 30] == 
+  == [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> 

−  import Data.Char (ord) 
+  import Data.Char (digitToInt) 
limit :: Integer 
limit :: Integer 

Line 190:  Line 193:  
fifth :: Integer > Integer 
fifth :: Integer > Integer 

−  fifth n = foldr (\a b > (toInteger(ord a)  48)^5 + b) 0 $ show n 
+  fifth = sum . map ((^5) . toInteger . digitToInt) . show 
problem_30 :: Integer 
problem_30 :: Integer 
Latest revision as of 03:52, 14 November 2011
Contents 
[edit] 1 Problem 21
Evaluate the sum of all amicable pairs 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..]
[edit] 2 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
[edit] 3 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]
[edit] 4 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)
[edit] 5 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)
[edit] 6 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)
[edit] 7 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
[edit] 8 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
euler28 n = sum $ scanl (+) 0 (1:(concatMap (replicate 4) [2,4..(n1)]))
[edit] 9 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]]
[edit] 10 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]