Euler problems/21 to 30
From HaskellWiki
(Fixed version 2 to have proper solution. Numbers whose divisor sum equals themselves are not amicable numbers.) 
(fix problem 25 which was messy and wrong) 

Line 87:  Line 87:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  valid ( i, n ) = length ( show n ) == 1000 
+  fibs = 0:1:(zipWith (+) fibs (tail fibs)) 
−  +  t = 10^999 

−  problem_25 = fst . head . filter valid . zip [ 1 .. ] $ fibs 
+  
−  where fibs = 1 : 1 : 2 : zipWith (+) fibs ( tail fibs ) 
+  problem_25 = length w 
+  where 

+  w = takeWhile (< t) fibs 

</haskell> 
</haskell> 

Revision as of 08:47, 16 December 2008
Contents 
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..]
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 . show . sum $ scores where score w i = (i *) . sum . map (\c > ord c  ord 'A' + 1) $ w
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 = putStrLn . show . foldl1 (+) . filter (not . isSum) $ [1..n]
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
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
6 Problem 26
Find the value of d < 1000 for which 1/d contains the longest recurring cycle.
Solution:
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)
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
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
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]
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 (ord) limit :: Integer limit = snd $ head $ dropWhile (\(a,b) > a > b) $ zip (map (9^5*) [1..]) (map (10^) [1..]) fifth :: Integer > Integer fifth n = foldr (\a b > (toInteger(ord a)  48)^5 + b) 0 $ show n problem_30 :: Integer problem_30 = sum $ filter (\n > n == fifth n) [2..limit]