Difference between revisions of "Euler problems/61 to 70"
(21 intermediate revisions by 8 users not shown) | |||
Line 1: | Line 1: | ||
+ | == [http://projecteuler.net/index.php?section=problems&id=61 Problem 61] == |
||
− | [[Category:Programming exercise spoilers]] |
||
− | == [http://projecteuler.net/index.php?section=view&id=61 Problem 61] == |
||
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property. |
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property. |
||
Line 6: | Line 5: | ||
<haskell> |
<haskell> |
||
import Data.List |
import Data.List |
||
+ | |||
− | |||
+ | permute [] = [[]] |
||
− | triangle = [n*(n+1)`div`2 | n <- [1..]] |
||
+ | permute xs = concatMap (\x -> map (x:) $ permute $ delete x xs) xs |
||
− | square = [n^2 | n <- [1..]] |
||
+ | |||
− | pentagonal = [n*(3*n-1)`div`2 | n <- [1..]] |
||
+ | figurates n xs = extract $ concatMap (gather (map poly xs)) $ map (:[]) $ poly n |
||
− | hexagonal = [n*(2*n-1) | n <- [1..]] |
||
+ | where gather [xs] (v:vs) |
||
− | heptagonal = [n*(5*n-3)`div`2 | n <- [1..]] |
||
− | + | = let v' = match xs v |
|
+ | in if v' == [] then [] else map (:v:vs) v' |
||
− | |||
+ | gather (xs:xss) (v:vs) |
||
− | triangle4 = fourDigs triangle |
||
− | + | = let v' = match xs v |
|
+ | in if v' == [] then [] else concatMap (gather xss) $ map (:v:vs) v' |
||
− | pentagonal4 = fourDigs pentagonal |
||
+ | match xs (_,v) = let p = (v `mod` 100)*100 in sublist (p+10,p+100) xs |
||
− | hexagonal4 = fourDigs hexagonal |
||
+ | sublist (s,e) = takeWhile (\(_,x) -> x<e) . dropWhile (\(_,x) -> x<s) |
||
− | heptagonal4 = fourDigs heptagonal |
||
+ | link ((_,x):xs) = x `mod` 100 == (snd $ last xs) `div` 100 |
||
− | octagonal4 = fourDigs octagonal |
||
+ | diff (x:y:xs) = if fst x /= fst y then diff (y:xs) else False |
||
− | |||
+ | diff [x] = True |
||
− | fourDigs = takeWhile (<10000) . dropWhile (<1000) |
||
+ | extract = filter diff . filter link |
||
− | |||
+ | poly m = [(n, x) | (n, x) <- zip [1..] $ takeWhile (<10000) |
||
− | solve = do |
||
+ | $ scanl (+) 1 [m-1,2*m-3..], |
||
− | (l1:l2:l3:l4:l5:l6:_) <- permute [triangle4, square4, pentagonal4, hexagonal4, heptagonal4, octagonal4] |
||
+ | 1010 < x, x `mod` 100 > 9] |
||
− | a <- l1 |
||
+ | |||
− | let m = filter (g a) l2 |
||
+ | problem_61 = sum $ map snd $ head $ concatMap (figurates 3) $ permute [4..8] |
||
− | 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 |
||
</haskell> |
</haskell> |
||
− | == [http://projecteuler.net/index.php?section= |
+ | == [http://projecteuler.net/index.php?section=problems&id=62 Problem 62] == |
Find the smallest cube for which exactly five permutations of its digits are cube. |
Find the smallest cube for which exactly five permutations of its digits are cube. |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.List |
||
− | problem_62 = undefined |
||
+ | import Data.Maybe |
||
+ | a = map (^3) [0..10000] |
||
+ | b = map (sort . show) a |
||
+ | c = filter ((==5) . length) . group . sort $ b |
||
+ | Just d = elemIndex (head (head c)) b |
||
+ | problem_62 = toInteger d^3 |
||
</haskell> |
</haskell> |
||
− | == [http://projecteuler.net/index.php?section= |
+ | == [http://projecteuler.net/index.php?section=problems&id=63 Problem 63] == |
How many n-digit positive integers exist which are also an nth power? |
How many n-digit positive integers exist which are also an nth power? |
||
Solution: |
Solution: |
||
− | Since d<sup>n</sup> has at least n+1 digits for any d≥10, we need only consider 1 through 9. If d<sup>n</sup> 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 d<sup>n</sup> for each d in {1,...,9}, trying n=1,2,... and stopping when d<sup>n</sup> has fewer than n digits. |
||
<haskell> |
<haskell> |
||
− | problem_63 |
+ | problem_63=length[x^y|x<-[1..9],y<-[1..22],y==(length$show$x^y)] |
− | $ [powers d | d <- [1..9]] |
||
− | where powers d = [(n, d^n) | n <- [1..]] |
||
− | nDigits n = length (show n) |
||
</haskell> |
</haskell> |
||
− | == [http://projecteuler.net/index.php?section= |
+ | == [http://projecteuler.net/index.php?section=problems&id=64 Problem 64] == |
How many continued fractions for N ≤ 10000 have an odd period? |
How many continued fractions for N ≤ 10000 have an odd period? |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.List |
||
− | problem_64 = undefined |
||
+ | |||
+ | problem_64 =length $ filter solve $ [2..9999] \\ (map (^2) [2..100]) |
||
+ | |||
+ | solve n = even $ length $ cont n 0 1 |
||
+ | |||
+ | cont :: Int -> Int -> Int -> [Int] |
||
+ | cont r n d = m : rest |
||
+ | where |
||
+ | m = (truncate (sqrt (fromIntegral r)) + n) `div` d |
||
+ | a = n - d * m |
||
+ | rest | d == 1 && n /= 0 = [] |
||
+ | | otherwise = cont r (-a) ((r - a ^ 2) `div` d) |
||
</haskell> |
</haskell> |
||
− | == [http://projecteuler.net/index.php?section= |
+ | == [http://projecteuler.net/index.php?section=problems&id=65 Problem 65] == |
Find the sum of digits in the numerator of the 100th convergent of the continued fraction for e. |
Find the sum of digits in the numerator of the 100th convergent of the continued fraction for e. |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.Char |
||
import Data.Ratio |
import Data.Ratio |
||
+ | |||
+ | e = 2 : concat [ [1, 2*i, 1] | i <- [1..] ] |
||
+ | |||
+ | fraction [x] = x%1 |
||
+ | fraction (x:xs) = x%1 + 1/(fraction xs) |
||
− | problem_65 = |
+ | problem_65 = sum $ map digitToInt $ show $ numerator $ fraction $ 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 |
||
</haskell> |
</haskell> |
||
− | == [http://projecteuler.net/index.php?section= |
+ | == [http://projecteuler.net/index.php?section=problems&id=66 Problem 66] == |
Investigate the Diophantine equation x<sup>2</sup> − Dy<sup>2</sup> = 1. |
Investigate the Diophantine equation x<sup>2</sup> − Dy<sup>2</sup> = 1. |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | intSqrt :: Integral a => a -> a |
||
− | problem_66 = undefined |
||
+ | intSqrt n |
||
+ | | n < 0 = error "intSqrt: negative n" |
||
+ | | otherwise = f n |
||
+ | where |
||
+ | f x | y < x = f y |
||
+ | | otherwise = x |
||
+ | where y = (x + (n `quot` x)) `quot` 2 |
||
+ | problem_66 = |
||
+ | snd$maximum [ (x,d) | |
||
+ | d <- [1..1000], |
||
+ | let b = intSqrt d, |
||
+ | b*b /= d, -- d can't be a perfect square |
||
+ | let (x,_) = pell d b b |
||
+ | ] |
||
+ | |||
+ | pell d wd b = piter d wd b 0 1 0 1 1 0 |
||
+ | piter d wd b i c l k m n |
||
+ | | cn == 1 = (x, y) |
||
+ | | otherwise = piter d wd bn (i+1) cn k u n v |
||
+ | where |
||
+ | yb = (wd+b) `div` c |
||
+ | bn = yb*c-b |
||
+ | cn = (d-(bn*bn)) `div` c |
||
+ | yn | i == 0 = wd |
||
+ | | otherwise = yb |
||
+ | u = k*yn+l -- u/v is the i-th convergent of sqrt(d) |
||
+ | v = n*yn+m |
||
+ | (x,y) | odd (i+1) = (u*u+d*v*v, 2*u*v) |
||
+ | | otherwise = (u,v) |
||
</haskell> |
</haskell> |
||
− | == [http://projecteuler.net/index.php?section= |
+ | == [http://projecteuler.net/index.php?section=problems&id=67 Problem 67] == |
Using an efficient algorithm find the maximal sum in the triangle? |
Using an efficient algorithm find the maximal sum in the triangle? |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | problem_67 = readFile "triangle.txt" >>= print . solve . parse |
||
− | import System.Process |
||
− | import IO |
||
+ | parse :: String -> [[Int]] -- restrict output type for 'read' function |
||
− | slurpURL url = do |
||
+ | parse = map (map read . words) . lines |
||
− | (_,out,_,_) <- runInteractiveCommand $ "curl " ++ url |
||
+ | |||
− | hGetContents out |
||
+ | solve = head . foldr1 step -- reverse pairewise addition from bottom to top |
||
− | |||
+ | step [] _ = [] -- returen empty list to avoid eception warning |
||
− | problem_67 = do |
||
+ | step (x:xs) (y:z:zs) = x + max y z : step xs (z:zs) |
||
− | src <- slurpURL "http://projecteuler.net/project/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 |
||
</haskell> |
</haskell> |
||
+ | Alternatively, one could add lists pairewise from top to bottom. However, this would require a check on maximum in the list, after the final step of additions. |
||
− | == [http://projecteuler.net/index.php?section=view&id=68 Problem 68] == |
||
+ | |||
+ | == [http://projecteuler.net/index.php?section=problems&id=68 Problem 68] == |
||
What is the maximum 16-digit string for a "magic" 5-gon ring? |
What is the maximum 16-digit string for a "magic" 5-gon ring? |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.List |
||
− | problem_68 = undefined |
||
+ | permute [] = [[]] |
||
+ | permute list = |
||
+ | concatMap (\(x:xs) -> map (x:) (permute xs)) |
||
+ | (take (length list) |
||
+ | (unfoldr (\l@(x:xs) -> Just (l, xs ++ [x])) list)) |
||
+ | problem_68 = |
||
+ | maximum $ map (concatMap show) poel |
||
+ | where |
||
+ | gon68 = [1..10] |
||
+ | knip = (length gon68) `div` 2 |
||
+ | (is,e:es) = splitAt knip gon68 |
||
+ | extnodes = map (e:) $ permute es |
||
+ | intnodes = map (\(p:ps) -> zipWith (\ x y -> [x, y]) |
||
+ | (p:ps) (ps++[p])) $ permute is |
||
+ | poel = [ concat hs | |
||
+ | uitsteeksels <- extnodes, |
||
+ | organen <- intnodes, |
||
+ | let hs = zipWith (:) uitsteeksels organen, |
||
+ | let subsom = map sum hs, |
||
+ | length (nub subsom) == 1 ] |
||
</haskell> |
</haskell> |
||
− | == [http://projecteuler.net/index.php?section= |
+ | == [http://projecteuler.net/index.php?section=problems&id=69 Problem 69] == |
Find the value of n ≤ 1,000,000 for which n/φ(n) is a maximum. |
Find the value of n ≤ 1,000,000 for which n/φ(n) is a maximum. |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | {-phi(n) = n*(1-1/p1)*(1-1/p2)*...*(1-1/pn) |
||
− | problem_69 = undefined |
||
+ | n/phi(n) = 1/(1-1/p1)*(1-1/p2)*...*(1-1/pn) |
||
+ | (1-1/p) will be minimal for a small p and 1/(1-1/p) will then be maximal |
||
+ | -} |
||
+ | primes=[2,3,5,7,11,13,17,19,23] |
||
+ | problem_69= |
||
+ | maximum [c| |
||
+ | b<-tail $ inits primes, |
||
+ | let c=product b, |
||
+ | c<10^6 |
||
+ | ] |
||
</haskell> |
</haskell> |
||
+ | Note: credit for arithmetic functions is due to [http://www.polyomino.f2s.com/ David Amos]. |
||
− | == [http://projecteuler.net/index.php?section=view&id=70 Problem 70] == |
||
+ | |||
+ | == [http://projecteuler.net/index.php?section=problems&id=70 Problem 70] == |
||
Investigate values of n for which φ(n) is a permutation of n. |
Investigate values of n for which φ(n) is a permutation of n. |
||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.List |
||
− | problem_70 = undefined |
||
+ | import Data.Function |
||
− | </haskell> |
||
+ | isPerm a b = null $ show a \\ show b |
||
+ | flsqr n x=x<(floor.sqrt.fromInteger) n |
||
+ | pairs n1 = |
||
+ | fst . minimumBy (compare `on` fn) $ [(m,pm)|a<-gena,b<-genb,let m=a*b,n>m,let pm=m-a-b+1,isPerm m pm] |
||
+ | where |
||
+ | n=fromInteger n1 |
||
+ | gena = dropWhile (flsqr n)$ takeWhile (flsqr (2*n)) primes |
||
+ | genb = dropWhile (flsqr (n `div` 2))$ takeWhile (flsqr n) primes |
||
+ | fn (x,px) = fromIntegral x / (fromIntegral px) |
||
+ | problem_70= pairs (10^7) |
||
− | [[Category:Tutorials]] |
||
+ | </haskell> |
||
− | [[Category:Code]] |
Latest revision as of 10:20, 18 May 2022
Problem 61
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property.
Solution:
import Data.List
permute [] = [[]]
permute xs = concatMap (\x -> map (x:) $ permute $ delete x xs) xs
figurates n xs = extract $ concatMap (gather (map poly xs)) $ map (:[]) $ poly n
where gather [xs] (v:vs)
= let v' = match xs v
in if v' == [] then [] else map (:v:vs) v'
gather (xs:xss) (v:vs)
= let v' = match xs v
in if v' == [] then [] else concatMap (gather xss) $ map (:v:vs) v'
match xs (_,v) = let p = (v `mod` 100)*100 in sublist (p+10,p+100) xs
sublist (s,e) = takeWhile (\(_,x) -> x<e) . dropWhile (\(_,x) -> x<s)
link ((_,x):xs) = x `mod` 100 == (snd $ last xs) `div` 100
diff (x:y:xs) = if fst x /= fst y then diff (y:xs) else False
diff [x] = True
extract = filter diff . filter link
poly m = [(n, x) | (n, x) <- zip [1..] $ takeWhile (<10000)
$ scanl (+) 1 [m-1,2*m-3..],
1010 < x, x `mod` 100 > 9]
problem_61 = sum $ map snd $ head $ concatMap (figurates 3) $ permute [4..8]
Problem 62
Find the smallest cube for which exactly five permutations of its digits are cube.
Solution:
import Data.List
import Data.Maybe
a = map (^3) [0..10000]
b = map (sort . show) a
c = filter ((==5) . length) . group . sort $ b
Just d = elemIndex (head (head c)) b
problem_62 = toInteger d^3
Problem 63
How many n-digit positive integers exist which are also an nth power?
Solution:
problem_63=length[x^y|x<-[1..9],y<-[1..22],y==(length$show$x^y)]
Problem 64
How many continued fractions for N ≤ 10000 have an odd period?
Solution:
import Data.List
problem_64 =length $ filter solve $ [2..9999] \\ (map (^2) [2..100])
solve n = even $ length $ cont n 0 1
cont :: Int -> Int -> Int -> [Int]
cont r n d = m : rest
where
m = (truncate (sqrt (fromIntegral r)) + n) `div` d
a = n - d * m
rest | d == 1 && n /= 0 = []
| otherwise = cont r (-a) ((r - a ^ 2) `div` d)
Problem 65
Find the sum of digits in the numerator of the 100th convergent of the continued fraction for e.
Solution:
import Data.Char
import Data.Ratio
e = 2 : concat [ [1, 2*i, 1] | i <- [1..] ]
fraction [x] = x%1
fraction (x:xs) = x%1 + 1/(fraction xs)
problem_65 = sum $ map digitToInt $ show $ numerator $ fraction $ take 100 e
Problem 66
Investigate the Diophantine equation x2 − Dy2 = 1.
Solution:
intSqrt :: Integral a => a -> a
intSqrt n
| n < 0 = error "intSqrt: negative n"
| otherwise = f n
where
f x | y < x = f y
| otherwise = x
where y = (x + (n `quot` x)) `quot` 2
problem_66 =
snd$maximum [ (x,d) |
d <- [1..1000],
let b = intSqrt d,
b*b /= d, -- d can't be a perfect square
let (x,_) = pell d b b
]
pell d wd b = piter d wd b 0 1 0 1 1 0
piter d wd b i c l k m n
| cn == 1 = (x, y)
| otherwise = piter d wd bn (i+1) cn k u n v
where
yb = (wd+b) `div` c
bn = yb*c-b
cn = (d-(bn*bn)) `div` c
yn | i == 0 = wd
| otherwise = yb
u = k*yn+l -- u/v is the i-th convergent of sqrt(d)
v = n*yn+m
(x,y) | odd (i+1) = (u*u+d*v*v, 2*u*v)
| otherwise = (u,v)
Problem 67
Using an efficient algorithm find the maximal sum in the triangle?
Solution:
problem_67 = readFile "triangle.txt" >>= print . solve . parse
parse :: String -> [[Int]] -- restrict output type for 'read' function
parse = map (map read . words) . lines
solve = head . foldr1 step -- reverse pairewise addition from bottom to top
step [] _ = [] -- returen empty list to avoid eception warning
step (x:xs) (y:z:zs) = x + max y z : step xs (z:zs)
Alternatively, one could add lists pairewise from top to bottom. However, this would require a check on maximum in the list, after the final step of additions.
Problem 68
What is the maximum 16-digit string for a "magic" 5-gon ring?
Solution:
import Data.List
permute [] = [[]]
permute list =
concatMap (\(x:xs) -> map (x:) (permute xs))
(take (length list)
(unfoldr (\l@(x:xs) -> Just (l, xs ++ [x])) list))
problem_68 =
maximum $ map (concatMap show) poel
where
gon68 = [1..10]
knip = (length gon68) `div` 2
(is,e:es) = splitAt knip gon68
extnodes = map (e:) $ permute es
intnodes = map (\(p:ps) -> zipWith (\ x y -> [x, y])
(p:ps) (ps++[p])) $ permute is
poel = [ concat hs |
uitsteeksels <- extnodes,
organen <- intnodes,
let hs = zipWith (:) uitsteeksels organen,
let subsom = map sum hs,
length (nub subsom) == 1 ]
Problem 69
Find the value of n ≤ 1,000,000 for which n/φ(n) is a maximum.
Solution:
{-phi(n) = n*(1-1/p1)*(1-1/p2)*...*(1-1/pn)
n/phi(n) = 1/(1-1/p1)*(1-1/p2)*...*(1-1/pn)
(1-1/p) will be minimal for a small p and 1/(1-1/p) will then be maximal
-}
primes=[2,3,5,7,11,13,17,19,23]
problem_69=
maximum [c|
b<-tail $ inits primes,
let c=product b,
c<10^6
]
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
import Data.Function
isPerm a b = null $ show a \\ show b
flsqr n x=x<(floor.sqrt.fromInteger) n
pairs n1 =
fst . minimumBy (compare `on` fn) $ [(m,pm)|a<-gena,b<-genb,let m=a*b,n>m,let pm=m-a-b+1,isPerm m pm]
where
n=fromInteger n1
gena = dropWhile (flsqr n)$ takeWhile (flsqr (2*n)) primes
genb = dropWhile (flsqr (n `div` 2))$ takeWhile (flsqr n) primes
fn (x,px) = fromIntegral x / (fromIntegral px)
problem_70= pairs (10^7)