Euler problems/61 to 70
From HaskellWiki
< Euler problems(Difference between revisions)
(→Problem 70) |
|||
| (30 intermediate revisions not shown.) | |||
| Line 4: | Line 4: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_61 = | + | 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] | ||
</haskell> | </haskell> | ||
| Line 12: | Line 34: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_62 = | + | 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 | ||
</haskell> | </haskell> | ||
| Line 20: | Line 48: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_63 = | + | problem_63=length[x^y|x<-[1..9],y<-[1..22],y==(length$show$x^y)] |
</haskell> | </haskell> | ||
| Line 28: | Line 56: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_64 = | + | 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) | ||
</haskell> | </haskell> | ||
| Line 36: | Line 76: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_65 = | + | 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 | ||
</haskell> | </haskell> | ||
== [http://projecteuler.net/index.php?section=problems&id=66 Problem 66] == | == [http://projecteuler.net/index.php?section=problems&id=66 Problem 66] == | ||
| - | Investigate the Diophantine equation | + | Investigate the Diophantine equation x<sup>2</sup> − Dy<sup>2</sup> = 1. |
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_66 = | + | 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) | ||
</haskell> | </haskell> | ||
| Line 52: | Line 129: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_67 = | + | problem_67 = readFile "triangle.txt" >>= print . solve . parse |
| + | parse = map (map read . words) . lines | ||
| + | solve = head . foldr1 step | ||
| + | step [] [z] = [z] | ||
| + | step (x:xs) (y:z:zs) = x + max y z : step xs (z:zs) | ||
</haskell> | </haskell> | ||
| Line 60: | Line 141: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_68 = | + | 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 ] | ||
</haskell> | </haskell> | ||
| Line 68: | Line 169: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | problem_69 = | + | {-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 | ||
| + | ] | ||
</haskell> | </haskell> | ||
| + | |||
| + | Note: credit for arithmetic functions is due to [http://www.polyomino.f2s.com/ David Amos]. | ||
== [http://projecteuler.net/index.php?section=problems&id=70 Problem 70] == | == [http://projecteuler.net/index.php?section=problems&id=70 Problem 70] == | ||
| Line 76: | Line 189: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | + | 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) | |
| - | + | </haskell> | |
Current revision
Contents |
1 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]
2 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
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)]
4 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)
5 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
6 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)
7 Problem 67
Using an efficient algorithm find the maximal sum in the triangle?
Solution:
problem_67 = readFile "triangle.txt" >>= print . solve . parse parse = map (map read . words) . lines solve = head . foldr1 step step [] [z] = [z] step (x:xs) (y:z:zs) = x + max y z : step xs (z:zs)
8 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 ]
9 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.
10 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)
