Personal tools

Euler problems/61 to 70

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(Problem 70)
 
(8 intermediate revisions by 3 users not shown)
Line 1: Line 1:
Do them on your own!
+
== [http://projecteuler.net/index.php?section=problems&id=61 Problem 61] ==
  +
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property.
  +
  +
Solution:
  +
<haskell>
  +
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>
  +
  +
== [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.
  +
  +
Solution:
  +
<haskell>
  +
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>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=63 Problem 63] ==
  +
How many n-digit positive integers exist which are also an nth power?
  +
  +
Solution:
  +
<haskell>
  +
problem_63=length[x^y|x<-[1..9],y<-[1..22],y==(length$show$x^y)]
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=64 Problem 64] ==
  +
How many continued fractions for N ≤ 10000 have an odd period?
  +
  +
Solution:
  +
<haskell>
  +
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>
  +
  +
== [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.
  +
  +
Solution:
  +
<haskell>
  +
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>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=66 Problem 66] ==
  +
Investigate the Diophantine equation x<sup>2</sup> − Dy<sup>2</sup> = 1.
  +
  +
Solution:
  +
<haskell>
  +
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>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=67 Problem 67] ==
  +
Using an efficient algorithm find the maximal sum in the triangle?
  +
  +
Solution:
  +
<haskell>
  +
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>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=68 Problem 68] ==
  +
What is the maximum 16-digit string for a "magic" 5-gon ring?
  +
  +
Solution:
  +
<haskell>
  +
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>
  +
  +
== [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.
  +
  +
Solution:
  +
<haskell>
  +
{-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>
  +
  +
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.
  +
  +
Solution:
  +
<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>

Latest revision as of 18:36, 9 September 2011

Contents

[edit] 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]

[edit] 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

[edit] 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)]

[edit] 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)

[edit] 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

[edit] 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)

[edit] 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)

[edit] 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 ]

[edit] 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.

[edit] 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)