Personal tools

Euler problems/61 to 70

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(Problem 70)
 
(10 intermediate revisions by 4 users not shown)
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=view&id=61 Problem 61] ==
+
== [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.
 
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property.
   
Line 29: Line 29:
 
</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.
   
Line 38: Line 38:
 
a = map (^3) [0..10000]
 
a = map (^3) [0..10000]
 
b = map (sort . show) a
 
b = map (sort . show) a
c = (filter ((==5) . length) . group . sort) b
+
c = filter ((==5) . length) . group . sort $ b
d = findIndex (==(head (head c))) b
+
Just d = elemIndex (head (head c)) b
problem_62 = (toInteger (fromJust d))^3
+
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?
   
Line 51: Line 51:
 
</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?
   
Line 58: Line 58:
 
import Data.List
 
import Data.List
 
 
problem_64 =length $ filter id $ map solve $ [2..9999] \\ (map (^2) [2..100])
+
problem_64 =length $ filter solve $ [2..9999] \\ (map (^2) [2..100])
 
 
 
solve n = even $ length $ cont n 0 1
 
solve n = even $ length $ cont n 0 1
Line 65: Line 65:
 
cont r n d = m : rest
 
cont r n d = m : rest
 
where
 
where
m = truncate ((sqrt (fromIntegral r) + fromIntegral n ) / fromIntegral d)
+
m = (truncate (sqrt (fromIntegral r)) + n) `div` d
 
a = n - d * m
 
a = n - d * m
rest = if d == 1 && n /= 0
+
rest | d == 1 && n /= 0 = []
then []
+
| otherwise = cont r (-a) ((r - a ^ 2) `div` d)
else 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.
   
Line 79: Line 79:
 
import Data.Ratio
 
import Data.Ratio
 
 
e = [2] ++ concat [ [1, 2*i, 1] | i <- [1..] ]
+
e = 2 : concat [ [1, 2*i, 1] | i <- [1..] ]
 
 
 
fraction [x] = x%1
 
fraction [x] = x%1
Line 87: Line 87:
 
</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.
   
Line 97: Line 97:
 
| otherwise = f n
 
| otherwise = f n
 
where
 
where
f x = if y < x then f y else x
+
f x | y < x = f y
  +
| otherwise = x
 
where y = (x + (n `quot` x)) `quot` 2
 
where y = (x + (n `quot` x)) `quot` 2
 
problem_66 =
 
problem_66 =
Line 123: Line 123:
 
</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?
   
Line 135: Line 135:
 
</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?
   
Line 143: Line 143:
 
permute [] = [[]]
 
permute [] = [[]]
 
permute list =
 
permute list =
concat $ map (\(x:xs) -> map (x:) (permute xs))
+
concatMap (\(x:xs) -> map (x:) (permute xs))
 
(take (length list)
 
(take (length list)
(unfoldr (\x -> Just (x, tail x ++ [head x])) list))
+
(unfoldr (\l@(x:xs) -> Just (l, xs ++ [x])) list))
 
problem_68 =
 
problem_68 =
maximum $ map (concat . map show) poel
+
maximum $ map (concatMap show) poel
 
where
 
where
 
gon68 = [1..10]
 
gon68 = [1..10]
 
knip = (length gon68) `div` 2
 
knip = (length gon68) `div` 2
(is,es) = splitAt knip gon68
+
(is,e:es) = splitAt knip gon68
extnodes = map (\x -> [head es]++x) $ permute $ tail es
+
extnodes = map (e:) $ permute es
intnodes = map (\(p:ps) -> zipWith (\ x y -> [x]++[y])
+
intnodes = map (\(p:ps) -> zipWith (\ x y -> [x, y])
 
(p:ps) (ps++[p])) $ permute is
 
(p:ps) (ps++[p])) $ permute is
poel = [ concat hs | hs <- [ zipWith (\x y -> [x]++y) uitsteeksels organen |
+
poel = [ concat hs |
uitsteeksels <- extnodes, organen <- intnodes ],
+
uitsteeksels <- extnodes,
let subsom = map (sum) hs, length (nub subsom) == 1 ]
+
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.
   
Line 172: Line 172:
 
problem_69=
 
problem_69=
 
maximum [c|
 
maximum [c|
a<-[1..length primes],
+
b<-tail $ inits primes,
let b=take a primes,
 
 
let c=product b,
 
let c=product b,
 
c<10^6
 
c<10^6
Line 180: Line 180:
 
Note: credit for arithmetic functions is due to [http://www.polyomino.f2s.com/ David Amos].
 
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.
   
Line 186: Line 186:
 
<haskell>
 
<haskell>
 
import Data.List
 
import Data.List
isPerm a b = (show a) \\ (show b)==[]
+
import Data.Function
  +
isPerm a b = null $ show a \\ show b
 
flsqr n x=x<(floor.sqrt.fromInteger) n
 
flsqr n x=x<(floor.sqrt.fromInteger) n
 
pairs n1 =
 
pairs n1 =
maximum[m|a<-gena ,b<-genb,let m=a*b,n>m,isPerm m$ m-a-b+1]
+
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
 
where
 
n=fromInteger n1
 
n=fromInteger n1
 
gena = dropWhile (flsqr n)$ takeWhile (flsqr (2*n)) primes
 
gena = dropWhile (flsqr n)$ takeWhile (flsqr (2*n)) primes
genb = dropWhile (flsqr (div n 2))$ takeWhile (flsqr n) primes
+
genb = dropWhile (flsqr (n `div` 2))$ takeWhile (flsqr n) primes
  +
fn (x,px) = fromIntegral x / (fromIntegral px)
   
 
problem_70= pairs (10^7)
 
problem_70= pairs (10^7)

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)