Personal tools

Euler problems/21 to 30

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
m (Cleaner problem_21)
Line 42: Line 42:
Solution:
Solution:
<haskell>
<haskell>
-
-- apply to a list of names
+
import Data.Char
-
problem_22 :: [String] -> Int
+
import Data.List
-
problem_22 = sum . zipWith (*) [ 1 .. ] . map score
+
problem_22 =
-
where score = sum . map ( subtract 64 . ord )
+
sum . zipWith (*) [ 1 .. ] . map score
 +
where
 +
score = sum . map ( subtract 64 . ord )
 +
main=do
 +
f<-readFile "names.txt"
 +
let names=sort$tail$("":)$read $"["++f++"]"
 +
print $problem_22 names
</haskell>
</haskell>
Line 54: Line 60:
<haskell>
<haskell>
import Data.List
import Data.List
-
-- 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.
+
-- 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.
-- http://www-maths.swan.ac.uk/pgrads/bb/project/node25.html
-- http://www-maths.swan.ac.uk/pgrads/bb/project/node25.html
notEven=[2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 26, 28, 34, 46]
notEven=[2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 26, 28, 34, 46]
Line 105: Line 114:
<haskell>
<haskell>
valid ( i, n ) = length ( show n ) == 1000
valid ( i, n ) = length ( show n ) == 1000
-
 
+
-
problem_25 = fst . head . filter valid . zip [ 1 .. ] $ fibs
+
problem_25 =
-
where fibs = 1 : 1 : 2 : zipWith (+) fibs ( tail fibs )
+
fst . head . filter valid . zip [ 1 .. ] $ fibs
 +
where
 +
fibs = 1 : 1 : 2 : zipWith (+) fibs ( tail fibs )
</haskell>
</haskell>
Line 115: Line 126:
Solution:
Solution:
<haskell>
<haskell>
-
problem_26 = fst $ maximumBy (\a b -> snd a `compare` snd b)
+
problem_26 =
 +
fst $ maximumBy (\a b -> snd a `compare` snd b)
[(n,recurringCycle n) | n <- [1..999]]
[(n,recurringCycle n) | n <- [1..999]]
-
where recurringCycle d = remainders d 10 []
+
where
-
remainders d 0 rs = 0
+
recurringCycle d = remainders d 10 []
-
remainders d r rs = let r' = r `mod` d
+
remainders d 0 rs = 0
-
in case findIndex (== r') rs of
+
remainders d r rs = let r' = r `mod` d
-
Just i -> i + 1
+
in case findIndex (== r') rs of
-
Nothing -> remainders d (10*r') (r':rs)
+
Just i -> i + 1
 +
Nothing -> remainders d (10*r') (r':rs)
</haskell>
</haskell>
Line 247: Line 260:
Solution:
Solution:
<haskell>
<haskell>
-
import Data.Char (ord)
+
import Data.Char
-
 
+
limit = snd $ head $ dropWhile (\(a,b) -> a > b)
-
limit :: Integer
+
$ zip (map (9^5*) [1..]) (map (10^) [1..])
-
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
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]
problem_30 = sum $ filter (\n -> n == fifth n) [2..limit]
</haskell>
</haskell>

Revision as of 02:30, 6 January 2008

Contents

1 Problem 21

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]

An alternative. 

problem_21_v2 = sum $ filter amic [1..10000]
  where amic n = n /= m && n == sdivs m
    where m = sdivs n
          sdivs n = sum $ filter (\m -> n `mod` m == 0) [1..n-1]

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

problem_21_v3 = sum [n | n <- [2..9999], let m = d n,
                         m > 1, m < 10000, n == 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.Char
import Data.List
problem_22 = 
    sum . zipWith (*) [ 1 .. ] . map score
    where 
    score = sum . map ( subtract 64 . ord )
main=do
    f<-readFile "names.txt"
    let names=sort$tail$("":)$read $"["++f++"]"
    print $problem_22 names

3 Problem 23

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

Solution: 

import Data.List 
-- 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.
-- http://www-maths.swan.ac.uk/pgrads/bb/project/node25.html
notEven=[2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 26, 28, 34, 46]
problem_23 = 1 +sum notEven +sum notOdd
 
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=x-b,y>1,(sum$factors y)-y>y ]
notOdd=[x|x<-[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

4 Problem 24

What is the millionth lexicographic permutation of the digits 0, 1, 2, 3, 4, 5, 6, 7, 8 and 9?

Solution: 

perms [] _= []
perms xs n= do
    let m=fac$(length(xs) -1)
    let y=div n m
    let x = xs!!y
    x:( perms ( delete x $ xs ) (mod n m))
 
problem_24 =  perms "0123456789"  999999

5 Problem 25

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

Solution: 

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 )

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:

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 $ ""

8 Problem 28

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

Solution: 

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

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 : 

problem_28 = sum . scanl (+) 1 . concatMap (replicate 4) $ [2,4..1000]

9 Problem 29

How many distinct terms are in the sequence generated by ab for 2 ≤ a ≤ 100 and 2 ≤ b ≤ 100?

Solution: 

problem_29 = length . group . sort $ [a^b | a <- [2..100], b <- [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
limit = snd $ head $ dropWhile (\(a,b) -> a > b) 
    $ zip (map (9^5*) [1..]) (map (10^) [1..])
 
fifth n = foldr (\a b -> (toInteger(ord a) - 48)^5 + b) 0 $ show n
 
problem_30 = sum $ filter (\n -> n == fifth n) [2..limit]
Retrieved from "http://www.haskell.org/haskellwiki/Euler_problems/21_to_30"