Euler problems/61 to 70
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
Problem 61
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property.
Solution:
import Data.List
triangle = [n*(n+1)`div`2 | n <- [1..]]
square = [n^2 | n <- [1..]]
pentagonal = [n*(3*n-1)`div`2 | n <- [1..]]
hexagonal = [n*(2*n-1) | n <- [1..]]
heptagonal = [n*(5*n-3)`div`2 | n <- [1..]]
octagonal = [n*(3*n-2) | n <- [1..]]
triangle4 = fourDigs triangle
square4 = fourDigs square
pentagonal4 = fourDigs pentagonal
hexagonal4 = fourDigs hexagonal
heptagonal4 = fourDigs heptagonal
octagonal4 = fourDigs octagonal
fourDigs = takeWhile (<10000) . dropWhile (<1000)
solve = do
(l1:l2:l3:l4:l5:l6:_) <- permute
[triangle4, square4, pentagonal4,
hexagonal4, heptagonal4, octagonal4]
a <- l1
let m = filter (g a) l2
b <- m
let n = filter (g b) l3
c <- n
let o = filter (g c) l4
d <- o
let p = filter (g d) l5
e <- p
let q = filter (g e) l6
f <- q
if g f a then return (sum [a,b,c,d,e,f]) else fail "burp"
where
g x y = x `mod` 100 == y `div` 100
permute :: [a] -> [[a]]
permute [] = [[]]
permute list =
concat $ map (\(x:xs) -> map (x:) (permute xs))
(take (length list)
(unfoldr (\x -> Just (x, tail x ++ [head x])) list))
problem_61 = head $ solve
Problem 62
Find the smallest cube for which exactly five permutations of its digits are cube.
Solution:
import Data.List
cubes = [(x, show $ x^3) | x <- [1..100000]]
problem_62 =
f3 $ head $ head $ sortBy shf $
filter l5 $ groupBy g $ sortBy ss $ map sd cubes
where
sd (a, b) = (a, sort b)
shf a b = compare (fst $ head a) (fst $ head b)
ss a b = compare (snd a) (snd b)
g a b = (snd a) == (snd b)
l5 a = length a == 5
f3 a = (fst a)^3
Problem 63
How many n-digit positive integers exist which are also an nth power?
Solution: Since dn has at least n+1 digits for any d≥10, we need only consider 1 through 9. If dn has fewer than n digits, every higher power of d will also be too small since d < 10. We will also never have n+1 digits for our nth powers. All we have to do is check dn for each d in {1,...,9}, trying n=1,2,... and stopping when dn has fewer than n digits.
problem_63 =
length . concatMap (takeWhile (\(n,p) -> n == nDigits p))
$ [powers d | d <- [1..9]]
where
powers d = [(n, d^n) | n <- [1..]]
nDigits n = length (show n)
Problem 64
How many continued fractions for N ≤ 10000 have an odd period?
Solution:
import Data.List (findIndex)
fraction n = (a0, 1, (-a0)) : nextDigits n 1 (-a0)
where
a0 = firstDigit n
nextDigits n num den
| n - (den^2) == 0 = []
| otherwise = (an, den', num') : nextDigits n den' num'
where
a0 = firstDigit n
den' = (n - (den^2)) `div` num
an = (a0 + abs den) `div` den'
num' = abs den - (an * den')
firstDigit n = floor $ sqrt $ fromInteger n
period [] = 0
period xs = period' [] xs
where
period' _ [] = 0
period' acc (x:xs) = case findIndex (x==) acc of
Just i -> toInteger(length acc - i)
Nothing -> period' (acc ++ [x]) xs
problem_64 =
length $ filter odd $
map (period . fraction) [1..10000]
Problem 65
Find the sum of digits in the numerator of the 100th convergent of the continued fraction for e.
Solution:
import Data.Ratio
problem_65 = dsum . numerator . contFrac . take 100 $ e
where dsum 0 = 0
dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d )
contFrac = foldr1 (\x y -> x + 1/y)
e = 2 : 1 : insOnes [2,4..]
insOnes (x:xs) = x : 1 : 1 : insOnes xs
Problem 66
Investigate the Diophantine equation x2 − Dy2 = 1.
Solution:
Problem solved using the continuous fractions method (reused from problem 64).
import Data.List (inits, maximumBy)
import Data.Ratio ((%), numerator, denominator)
fraction :: Integer -> [Integer]
fraction n = a0 : nextDigits n 1 (-a0)
where
a0 = firstDigit n
firstDigit :: Integer -> Integer
firstDigit n = floor $ sqrt $ fromInteger n
nextDigits :: Integer -> Integer -> Integer -> [Integer]
nextDigits n num den
| n - (den^2) == 0 = []
| otherwise = an : nextDigits n den' num'
where
a0 = firstDigit n
den' = (n - (den^2)) `div` num
an = (a0 + abs den) `div` den'
num' = abs den - (an * den')
nonSquares :: [Integer]
nonSquares = [x|x <- [2..1000], let s = floor $ sqrt $ fromInteger x, s*s /= x]
minDiophantineX :: Integer -> Integer
minDiophantineX d =
numerator $ head $
filter isDiophantine $
map (calc) $ drop 1 $ inits $ fraction d
where
calc x =
foldr (\a b -> fromInteger a + 1/b)
((fromInteger $ last x)%1) $ init x
isDiophantine (r) = (numerator r)^2 - d * (denominator r)^2 == 1
maxDiophantine :: [(Integer, Integer)]
maxDiophantine = [(d,minDiophantineX d)|d <- nonSquares]
problem_66 :: Integer
problem_66 = fst $ maximumBy (\(_,a) (_,b) -> compare a b) maxDiophantine
Problem 67
Using an efficient algorithm find the maximal sum in the triangle?
Solution:
problem_67 = do
src <- readFile "triangle.txt"
print $ head $ foldr1 g $ parse src
where
parse :: String -> [[Int]]
parse s = map ((map read).words) $ lines s
f x y z = x + max y z
g xs ys = zipWith3 f xs ys $ tail ys
Problem 68
What is the maximum 16-digit string for a "magic" 5-gon ring?
Solution:
import Data.List (delete, group, sort)
numberSets :: Int -> [(Int, Int, Int)]
numberSets n =
[(a,b,c)|
a <- [1..10],
b <- delete a [1..10],
let c = n - a - b,
c > 0,
c < 11,
a /= c,
b /= c
]
nextSets :: (Int, Int, Int) -> [(Int, Int, Int)]
nextSets (a,b,c) = filter f $ numberSets s
where
s = a + b + c
f x = follows (a, b, c) x
follows :: (Int, Int, Int) -> (Int, Int, Int) -> Bool
follows (_,_,c) (_,b',_) = c == b'
lowest :: (Ord a) => [a] -> [a]
lowest xs = minimum $ take 6 $ iterate rotate xs
where
rotate [] = []
rotate (y:ys) = ys ++ [y]
solutions :: [[(Int, Int, Int)]]
solutions = do
n <- [13..27]
a <- numberSets n
b <- nextSets a
c <- nextSets b
d <- nextSets c
e <- nextSets d
if follows e a then return [a,b,c,d,e] else fail "not cyclic"
magic :: (Ord a) => [a] -> [(a, a, a)] -> Bool
magic acc [] = (length $ group $ sort acc) == 10
magic acc ((a,b,c):xs) = magic (acc++[a,b,c]) xs
problem_69 :: [Char]
problem_69 =
maximum $ filter (\x -> length x == 16) $
map (toNum . lowest) $
filter (magic []) solutions
where
toNum [] = []
toNum ((a,b,c):xs) = show a ++ show b ++ show c ++ toNum xs
Problem 69
Find the value of n ≤ 1,000,000 for which n/φ(n) is a maximum.
Solution:
import Data.Ratio
import Data.List
primePowerFactors n = rle (takeFactors n primes)
where rle = map (\xs -> (head xs, length xs)) . group
takeFactors n (p:ps)
| n == 1 = []
| p * p > n = [n]
| n `mod` p == 0 = p : takeFactors (n `div` p) (p:ps)
| otherwise = takeFactors n ps
eulerTotient n = product (map (\(p,i) -> p^(i-1) * (p-1)) factors)
where factors = primePowerFactors n
problem_69 =
snd . maximum . map
(\n -> (n % eulerTotient n, n)) $
[1..1000000]
Note: credit for arithmetic functions is due to David Amos.
Problem 70
Investigate values of n for which φ(n) is a permutation of n.
Solution:
import Data.List (minimumBy, group, sort)
primes :: [Int]
primes = 2 : filter (l1 . primeFactors) [3,5..]
where
l1 (_:[]) = True
l1 _ = False
primeFactors :: Int -> [Int]
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
primePowerFactors :: Int -> [(Int, Int)]
primePowerFactors n =
map (\x -> (head x, length x)) $ (group . primeFactors) n
phi :: Int -> Int
phi n = product (map f $ primePowerFactors n)
where
f (p, l) = (p-1)*(p^(l-1))
isPermutation :: (Show a) => a -> a -> Bool
isPermutation a b = (sort $ show a) == (sort $ show b)
phiPerms :: [(Int, Int)]
phiPerms = [(n, p)| n <- [2..10000000], let p = phi n, isPermutation n p]
problem_70 :: Int
problem_70 =
fst $ minimumBy
(\(a,b) (a',b') -> compare (fromIntegral a/fromIntegral b)
(fromIntegral a'/fromIntegral b')) phiPerms