Euler problems/21 to 30
Evaluate the sum of all amicable pairs under 10000.
Solution: 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]
What is the total of all the name scores in the file of first names?
-- apply to a list of names problem_22 :: [String] -> Int problem_22 = sum . zipWith (*) [ 1 .. ] . map score where score = sum . map ( subtract 64 . ord )
Find the sum of all the positive integers which cannot be written as the sum of two abundant numbers.
module Main where import Data.Set hiding (filter, map) import Data.List (scanl, group) main :: IO () main = do print $ sum [1..28123] - (fold (+) 0 $ abundant_sums $ abundant 28123) abundant_sums :: [Integer] -> Set Integer abundant_sums  = empty abundant_sums l@(x:xs) = union (fromList [x + a | a <- takeWhile (\y -> y <= 28123 - x) l]) (abundant_sums xs) abundant :: Integer -> [Integer] abundant n = [a | a <- [1..n], (sum $ factors a) - a > a] 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  =  perms (x:xs) = perms xs ++ concatMap (\z -> map (*z) $ perms xs) x
What is the millionth lexicographic permutation of the digits 0, 1, 2, 3, 4, 5, 6, 7, 8 and 9?
perms  = [] perms xs = do x <- xs map ( x: ) ( perms . delete x $ xs ) problem_24 = ( perms "0123456789" ) !! 999999
What is the first term in the Fibonacci sequence to contain 1000 digits?
valid ( i, n ) = length ( show n ) == 1000 problem_25 = fst . head . filter valid . zip [ 1 .. ] $ fibs where fibs = 1 : 1 : 2 : zipWith (+) fibs ( tail fibs )
Find the value of d < 1000 for which 1/d contains the longest recurring cycle.
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)
Find a quadratic formula that produces the maximum number of primes for consecutive values of n.
The following is written in literate Haskell:
> import Data.List To be sure we get the maximum type checking of the compiler, we switch off the default type > default () Generate a list of primes. It works by filtering out numbers that are divisable by a previously found prime > primes :: [Int] > primes = sieve (2 : [3, 5..]) > where > sieve (p:xs) = p : sieve (filter (\x -> x `mod` p > 0) xs) > isPrime :: Int -> Bool > isPrime x = x `elem` (takeWhile (<= x) primes) The lists of values we are going to try for a and b; b must be a prime, as n² + an + b is equal to b when n = 0 > testRangeA :: [Int] > testRangeA = [-1000 .. 1000] > testRangeB :: [Int] > testRangeB = takeWhile (< 1000) primes The search > bestCoefficients :: (Int, Int, Int) > bestCoefficients = > maximumBy (\(x, _, _) (y, _, _) -> compare x y) $ > [f a b | a <- testRangeA, b <- testRangeB] > 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) > f a b = ( length $ contiguousPrimes a b > , a > , b > ) > contiguousPrimes :: Int -> Int -> [Int] > contiguousPrimes a b = takeWhile isPrime (map (quadratic a b) [0..]) The quadratic formula > quadratic :: Int -> Int -> Int -> Int > quadratic a b n = n * n + a * n + b > problem_27 = > 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 $ ""
What is the sum of both diagonals in a 1001 by 1001 spiral?
corners :: Int -> (Int, Int, Int, Int) corners i = (n*n, 1+(n*(2*m)), 2+(n*(2*m-1)), 3+(n*(2*m-2))) where m = (i-1) `div` 2 n = 2*m+1 sumcorners :: Int -> Int sumcorners i = a+b+c+d where (a, b, c, d) = corners i sumdiags :: Int -> Int sumdiags i | even i = error "not a spiral" | i == 3 = s + 1 | otherwise = s + sumdiags (i-2) where s = sumcorners i problem_28 = sumdiags 1001
How many distinct terms are in the sequence generated by ab for 2 ≤ a ≤ 100 and 2 ≤ b ≤ 100?
problem_29 = length . group . sort $ [a^b | a <- [2..100], b <- [2..100]]
Find the sum of all the numbers that can be written as the sum of fifth powers of their digits.
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]