Personal tools

Euler problems/61 to 70

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Current revision (18:36, 9 September 2011) (edit) (undo)
(→Problem 70)
 
(20 intermediate revisions not shown.)
Line 1: Line 1:
-
[[Category:Programming exercise spoilers]]
+
== [http://projecteuler.net/index.php?section=problems&id=61 Problem 61] ==
-
== [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
-
 
+
-
triangle = [n*(n+1)`div`2 | n <- [1..]]
+
permute [] = [[]]
-
square = [n^2 | n <- [1..]]
+
permute xs = concatMap (\x -> map (x:) $ permute $ delete x xs) xs
-
pentagonal = [n*(3*n-1)`div`2 | n <- [1..]]
+
-
hexagonal = [n*(2*n-1) | n <- [1..]]
+
figurates n xs = extract $ concatMap (gather (map poly xs)) $ map (:[]) $ poly n
-
heptagonal = [n*(5*n-3)`div`2 | n <- [1..]]
+
where gather [xs] (v:vs)
-
octagonal = [n*(3*n-2) | n <- [1..]]
+
= let v' = match xs v
-
 
+
in if v' == [] then [] else map (:v:vs) v'
-
triangle4 = fourDigs triangle
+
gather (xs:xss) (v:vs)
-
square4 = fourDigs square
+
= let v' = match xs v
-
pentagonal4 = fourDigs pentagonal
+
in if v' == [] then [] else concatMap (gather xss) $ map (:v:vs) v'
-
hexagonal4 = fourDigs hexagonal
+
match xs (_,v) = let p = (v `mod` 100)*100 in sublist (p+10,p+100) xs
-
heptagonal4 = fourDigs heptagonal
+
sublist (s,e) = takeWhile (\(_,x) -> x<e) . dropWhile (\(_,x) -> x<s)
-
octagonal4 = fourDigs octagonal
+
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
-
fourDigs = takeWhile (<10000) . dropWhile (<1000)
+
diff [x] = True
-
 
+
extract = filter diff . filter link
-
solve = do
+
poly m = [(n, x) | (n, x) <- zip [1..] $ takeWhile (<10000)
-
(l1:l2:l3:l4:l5:l6:_) <- permute [triangle4, square4, pentagonal4, hexagonal4, heptagonal4, octagonal4]
+
$ scanl (+) 1 [m-1,2*m-3..],
-
a <- l1
+
1010 < x, x `mod` 100 > 9]
-
let m = filter (g a) l2
+
-
b <- m
+
problem_61 = sum $ map snd $ head $ concatMap (figurates 3) $ permute [4..8]
-
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=view&id=62 Problem 62] ==
+
== [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>
-
problem_62 = undefined
+
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>
-
== [http://projecteuler.net/index.php?section=view&id=63 Problem 63] ==
+
== [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 = length . concatMap (takeWhile (\(n,p) -> n == nDigits p))
+
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=view&id=64 Problem 64] ==
+
== [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>
-
problem_64 = undefined
+
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>
-
== [http://projecteuler.net/index.php?section=view&id=65 Problem 65] ==
+
== [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 = dsum . numerator . contFrac . take 100 $ e
+
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=view&id=66 Problem 66] ==
+
== [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>
-
problem_66 = undefined
+
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>
-
== [http://projecteuler.net/index.php?section=view&id=67 Problem 67] ==
+
== [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>
-
import System.Process
+
problem_67 = readFile "triangle.txt" >>= print . solve . parse
-
import IO
+
parse = map (map read . words) . lines
-
 
+
solve = head . foldr1 step
-
slurpURL url = do
+
step [] [z] = [z]
-
(_,out,_,_) <- runInteractiveCommand $ "curl " ++ url
+
step (x:xs) (y:z:zs) = x + max y z : step xs (z:zs)
-
hGetContents out
+
-
+
-
problem_67 = do
+
-
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>
-
== [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>
-
problem_68 = undefined
+
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>
-
== [http://projecteuler.net/index.php?section=view&id=69 Problem 69] ==
+
== [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>
-
problem_69 = undefined
+
{-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>
-
== [http://projecteuler.net/index.php?section=view&id=70 Problem 70] ==
+
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] ==
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>
-
problem_70 = undefined
+
import Data.List
-
</haskell>
+
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)
-
[[Category:Tutorials]]
+
problem_70= pairs (10^7)
-
[[Category:Code]]
+
</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)
Retrieved from "http://www.haskell.org/haskellwiki/Euler_problems/61_to_70"