Personal tools

Euler problems/21 to 30

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(Problem 24: Added another method for Problem 24)
 
(30 intermediate revisions by 15 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.
 
<haskell>
 
<haskell>
problem_21 =
+
problem_21 = sum [m+n | m <- [2..9999], let n = divisorsSum ! m, amicable m n]
sum [n |
+
where amicable m n = m < n && n < 10000 && divisorsSum ! n == m
n <- [2..9999],
+
divisorsSum = array (1,9999)
let m = eulerTotient n,
+
[(i, sum (divisors i)) | i <- [1..9999]]
m > 1,
+
divisors n = [j | j <- [1..n `div` 2], n `mod` j == 0]
m < 10000,
 
n == eulerTotient m
 
]
 
 
</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.
  +
<haskell>
  +
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..]
  +
</haskell>
  +
  +
== [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?
   
Line 18: Line 18:
 
import Data.List
 
import Data.List
 
import Data.Char
 
import Data.Char
problem_22 = do
+
problem_22 =
input <- readFile "names.txt"
+
do input <- readFile "names.txt"
let names = sort $ read$"["++ input++"]"
+
let names = sort $ read$"["++ input++"]"
let scores = zipWith score names [1..]
+
let scores = zipWith score names [1..]
print $ show $ sum $ scores
+
print . sum $ scores
where
+
where score w i = (i *) . sum . map (\c -> ord c - ord 'A' + 1) $ w
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>
  +
--http://www.research.att.com/~njas/sequences/A048242
 
import Data.Array
 
import Data.Array
 
n = 28124
 
n = 28124
Line 40: Line 41:
 
isSum = any (abunds_array !) . rests
 
isSum = any (abunds_array !) . rests
   
problem_23 = putStrLn $ show $ foldl1 (+) $ filter (not . isSum) [1..n]
+
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?
   
Line 53: Line 54:
 
fac n = n * fac (n - 1)
 
fac n = n * fac (n - 1)
 
perms [] _= []
 
perms [] _= []
perms xs n=
+
perms xs n= x : perms (delete x xs) (mod n m)
x:( perms ( delete x $ xs ) (mod n m))
+
where m = fac $ length xs - 1
where
+
y = div n m
m=fac$(length(xs) -1)
+
x = xs!!y
y=div n m
 
x = xs!!y
 
 
 
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?
+
<haskell>
  +
import Data.List
  +
problem_24 = (!! 999999) . sort $ permutations ['0'..'9']
  +
</haskell>
  +
  +
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"
   
Solution:
 
 
<haskell>
 
<haskell>
  +
  +
-- 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
 
import Data.List
fib x
 
|x==0=0
 
|x==1=1
 
|x==2=1
 
|odd x=(fib (d+1))^2+(fib d)^2
 
|otherwise=(fib (d+1))^2-(fib (d-1))^2
 
where
 
d=div x 2
 
   
phi=(1+sqrt 5)/2
+
factorial n = product [1..n]
dig x=floor( (fromInteger x-1) * log 10 /log phi)
+
problem_25 =
+
-- lexOrder "0123456789" 1000000 ""
head[a|a<-[dig num..],(>=limit)$fib a]
+
  +
lexOrder digits left s
  +
| len == 0 = s ++ digits
  +
| quot > 0 && rem == 0 = lexOrder (digits\\(show (digits!!(quot-1)))) rem (s ++ [(digits!!(quot-1))])
  +
| 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
 
where
num=1000
+
len = (length digits) - 1
limit=10^(num-1)
+
(quot,rem) = quotRem left (factorial len)
  +
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=26 Problem 26] ==
+
== [http://projecteuler.net/index.php?section=problems&id=25 Problem 25] ==
Find the value of d < 1000 for which 1/d contains the longest recurring cycle.
+
What is the first term in the Fibonacci sequence to contain 1000 digits?
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
next n d = (n `mod` d):next (10*n`mod`d) d
+
fibs = 0:1:(zipWith (+) fibs (tail fibs))
  +
t = 10^999
   
idigs n = tail $ take (1+n) $ next 1 n
+
problem_25 = length w
  +
where
  +
w = takeWhile (< t) fibs
  +
</haskell>
   
pos x = map fst . filter ((==x) . snd) . zip [1..]
 
   
periods n = let d = idigs n in pos (head d) (tail d)
+
Casey Hawthorne
   
problem_26 =
+
I believe you mean the following:
snd$maximum [(m,a)|
+
a<-[800..1000] ,
+
<haskell>
let k=periods a,
+
not$null k,
+
fibs = 0:1:(zipWith (+) fibs (tail fibs))
let m=head k
+
]
+
last (takeWhile (<10^1000) fibs)
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=27 Problem 27] ==
+
== [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>
  +
  +
== [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.
 
Find a quadratic formula that produces the maximum number of primes for consecutive values of n.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
eulerCoefficients n
+
problem_27 = -(2*a-1)*(a^2-a+41)
= [((len, a*b), (a, b))
+
where n = 1000
| b <- takeWhile (<n) primes, a <- [-b+1..n-1],
+
m = head $ filter (\x->x^2-x+41>n) [1..]
let len = length $ takeWhile (isPrime . (\x -> x^2 + a*x + b)) [0..],
+
a = m-1
if b == 2 then even a else odd a, len > 39]
 
 
problem_27 = snd . fst . maximum . eulerCoefficients $ 1000
 
 
</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?
   
Line 126: Line 138:
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=29 Problem 29] ==
+
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..(n-1)]))
  +
</haskell>
  +
  +
== [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?
   
Line 135: Line 147:
 
</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>
import Data.Array
+
import Data.Char (digitToInt)
import Data.Char
+
+
limit :: Integer
p = listArray (0,9) $ map (^5) [0..9]
+
limit = snd $ head $ dropWhile (\(a,b) -> a > b) $ zip (map (9^5*) [1..]) (map (10^) [1..])
+
upperLimit = 295277
+
fifth :: Integer -> Integer
+
fifth = sum . map ((^5) . toInteger . digitToInt) . show
candidates =
+
[ n |
+
problem_30 :: Integer
n <- [10..upperLimit],
+
problem_30 = sum $ filter (\n -> n == fifth n) [2..limit]
(sum $ digits n) `mod` 10 == last(digits n),
 
powersum n == n
 
]
 
where
 
digits n = map digitToInt $ show n
 
powersum n = sum $ map (p!) $ digits n
 
 
problem_30 = sum candidates
 
 
</haskell>
 
</haskell>

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!!(quot-1))))  rem (s ++ [(digits!!(quot-1))])
    | 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*a-1)*(a^2-a+41)
  where n = 1000
        m = head $ filter (\x->x^2-x+41>n) [1..]
        a = m-1

[edit] 8 Problem 28

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

Solution:

problem_28 = sum (map (\n -> 4*(n-2)^2+10*(n-1)) [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..(n-1)]))

[edit] 9 Problem 29

How many distinct terms are in the sequence generated by ab 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]