Personal tools

Euler problems/61 to 70

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
Line 5: 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
+
$ scanl (+) 1 [m-1,2*m-3..],
-
[triangle4, square4, pentagonal4,
+
1010 < x, x `mod` 100 > 9]
-
hexagonal4, heptagonal4, octagonal4]
+
-
a <- l1
+
problem_61 = sum $ map snd $ head $ concatMap (figurates 3) $ permute [4..8]
-
let m = filter (g a) l2
+
-
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>
Line 57: Line 35:
<haskell>
<haskell>
import Data.List
import Data.List
-
 
+
import Data.Maybe
-
cubes = [(x, show $ x^3) | x <- [1..100000]]
+
a = map (^3) [0..10000]
-
 
+
b = map (sort . show) a
-
problem_62 =
+
c = (filter ((==5) . length) . group . sort) b
-
f3 $ head $ head $ sortBy shf $
+
d = findIndex (==(head (head c))) b
-
filter l5 $ groupBy g $ sortBy ss $ map sd cubes
+
problem_62 = (toInteger (fromJust d))^3
-
where
+
-
sd (a, b) = (a, sort b)
+
-
shf a b = compare (fst $ head a) (fst $ head b)
+
-
ss a b = compare (snd a) (snd b)
+
-
g a b = (snd a) == (snd b)
+
-
l5 a = length a == 5
+
-
f3 a = (fst a)^3
+
</haskell>
</haskell>
Line 76: Line 47:
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)]
-
length . concatMap (takeWhile (\(n,p) -> n == nDigits p))
+
-
$ [powers d | d <- [1..9]]
+
-
where
+
-
powers d = [(n, d^n) | n <- [1..]]
+
-
nDigits n = length (show n)
+
</haskell>
</haskell>
Line 91: Line 56:
Solution:
Solution:
<haskell>
<haskell>
-
import Data.List (findIndex)
+
import Data.List
-
 
+
-
fraction n = (a0, 1, (-a0)) : nextDigits n 1 (-a0)
+
problem_64 =length $ filter id $ map 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
where
-
a0 = firstDigit n
+
m = truncate ((sqrt (fromIntegral r) + fromIntegral n ) / fromIntegral d)
-
 
+
a = n - d * m
-
nextDigits n num den
+
rest = if d == 1 && n /= 0
-
| n - (den^2) == 0 = []
+
then []
-
| otherwise = (an, den', num') : nextDigits n den' num'
+
else cont r (-a) ((r - a ^ 2) `div` d)
-
where
+
-
a0 = firstDigit n
+
-
den' = (n - (den^2)) `div` num
+
-
an = (a0 + abs den) `div` den'
+
-
num' = abs den - (an * den')
+
-
 
+
-
firstDigit n = floor $ sqrt $ fromInteger n
+
-
 
+
-
period [] = 0
+
-
period xs = period' [] xs
+
-
where
+
-
period' _ [] = 0
+
-
period' acc (x:xs) = case findIndex (x==) acc of
+
-
Just i -> toInteger(length acc - i)
+
-
Nothing -> period' (acc ++ [x]) xs
+
-
 
+
-
problem_64 =
+
-
length $ filter odd $
+
-
map (period . fraction) [1..10000]
+
</haskell>
</haskell>
Line 126: Line 77:
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>
Line 140: Line 92:
Solution:
Solution:
-
 
-
Problem solved using the continuous fractions method (reused from problem 64).
 
<haskell>
<haskell>
-
import Data.List (inits, maximumBy)
+
intSqrt :: Integral a => a -> a
-
import Data.Ratio ((%), numerator, denominator)
+
intSqrt n
-
 
+
| n < 0 = error "intSqrt: negative n"
-
fraction :: Integer -> [Integer]
+
| otherwise = f n
-
fraction n = a0 : nextDigits n 1 (-a0)
+
where
where
-
a0 = firstDigit n
+
f x = if y < x then f y else 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
 +
]
-
firstDigit :: Integer -> Integer
+
pell d wd b = piter d wd b 0 1 0 1 1 0
-
firstDigit n = floor $ sqrt $ fromInteger n
+
piter d wd b i c l k m n
-
 
+
| cn == 1 = (x, y)
-
nextDigits :: Integer -> Integer -> Integer -> [Integer]
+
| otherwise = piter d wd bn (i+1) cn k u n v
-
nextDigits n num den
+
where
-
| n - (den^2) == 0 = []
+
yb = (wd+b) `div` c
-
| otherwise = an : nextDigits n den' num'
+
bn = yb*c-b
-
where
+
cn = (d-(bn*bn)) `div` c
-
a0 = firstDigit n
+
yn | i == 0 = wd
-
den' = (n - (den^2)) `div` num
+
| otherwise = yb
-
an = (a0 + abs den) `div` den'
+
u = k*yn+l -- u/v is the i-th convergent of sqrt(d)
-
num' = abs den - (an * den')
+
v = n*yn+m
-
 
+
(x,y) | odd (i+1) = (u*u+d*v*v, 2*u*v)
-
nonSquares :: [Integer]
+
| otherwise = (u,v)
-
nonSquares = [x|x <- [2..1000], let s = floor $ sqrt $ fromInteger x, s*s /= x]
+
-
 
+
-
minDiophantineX :: Integer -> Integer
+
-
minDiophantineX d =
+
-
numerator $ head $
+
-
filter isDiophantine $
+
-
map (calc) $ drop 1 $ inits $ fraction d
+
-
where
+
-
calc x =
+
-
foldr (\a b -> fromInteger a + 1/b)
+
-
((fromInteger $ last x)%1) $ init x
+
-
isDiophantine (r) = (numerator r)^2 - d * (denominator r)^2 == 1
+
-
 
+
-
maxDiophantine :: [(Integer, Integer)]
+
-
maxDiophantine = [(d,minDiophantineX d)|d <- nonSquares]
+
-
 
+
-
problem_66 :: Integer
+
-
problem_66 = fst $ maximumBy (\(_,a) (_,b) -> compare a b) maxDiophantine
+
</haskell>
</haskell>
Line 190: Line 129:
Solution:
Solution:
<haskell>
<haskell>
-
problem_67 = do
+
problem_67 = readFile "triangle.txt" >>= print . solve . parse
-
src <- readFile "triangle.txt"
+
parse = map (map read . words) . lines
-
print $ head $ foldr1 g $ parse src
+
solve = head . foldr1 step
-
where
+
step [] [z] = [z]
-
parse :: String -> [[Int]]
+
step (x:xs) (y:z:zs) = x + max y z : step xs (z:zs)
-
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>
Line 206: Line 141:
Solution:
Solution:
<haskell>
<haskell>
-
import Data.List (delete, group, sort)
+
import Data.List
-
 
+
permute [] = [[]]
-
numberSets :: Int -> [(Int, Int, Int)]
+
permute list =
-
numberSets n =
+
concat $ map (\(x:xs) -> map (x:) (permute xs))
-
[(a,b,c)|
+
(take (length list)
-
a <- [1..10],
+
(unfoldr (\x -> Just (x, tail x ++ [head x])) list))
-
b <- delete a [1..10],
+
problem_68 =
-
let c = n - a - b,
+
maximum $ map (concat . map show) poel
-
c > 0,
+
-
c < 11,
+
-
a /= c,
+
-
b /= c
+
-
]
+
-
 
+
-
nextSets :: (Int, Int, Int) -> [(Int, Int, Int)]
+
-
nextSets (a,b,c) = filter f $ numberSets s
+
where
where
-
s = a + b + c
+
gon68 = [1..10]
-
f x = follows (a, b, c) x
+
knip = (length gon68) `div` 2
-
 
+
(is,es) = splitAt knip gon68
-
follows :: (Int, Int, Int) -> (Int, Int, Int) -> Bool
+
extnodes = map (\x -> [head es]++x) $ permute $ tail es
-
follows (_,_,c) (_,b',_) = c == b'
+
intnodes = map (\(p:ps) -> zipWith (\ x y -> [x]++[y])
-
 
+
(p:ps) (ps++[p])) $ permute is
-
lowest :: (Ord a) => [a] -> [a]
+
poel = [ concat hs | hs <- [ zipWith (\x y -> [x]++y) uitsteeksels organen |
-
lowest xs = minimum $ take 6 $ iterate rotate xs
+
uitsteeksels <- extnodes, organen <- intnodes ],
-
where
+
let subsom = map (sum) hs, length (nub subsom) == 1 ]
-
rotate [] = []
+
-
rotate (y:ys) = ys ++ [y]
+
-
 
+
-
solutions :: [[(Int, Int, Int)]]
+
-
solutions = do
+
-
n <- [13..27]
+
-
a <- numberSets n
+
-
b <- nextSets a
+
-
c <- nextSets b
+
-
d <- nextSets c
+
-
e <- nextSets d
+
-
if follows e a then return [a,b,c,d,e] else fail "not cyclic"
+
-
 
+
-
magic :: (Ord a) => [a] -> [(a, a, a)] -> Bool
+
-
magic acc [] = (length $ group $ sort acc) == 10
+
-
magic acc ((a,b,c):xs) = magic (acc++[a,b,c]) xs
+
-
 
+
-
problem_69 :: [Char]
+
-
problem_69 =
+
-
maximum $ filter (\x -> length x == 16) $
+
-
map (toNum . lowest) $
+
-
filter (magic []) solutions
+
-
where
+
-
toNum [] = []
+
-
toNum ((a,b,c):xs) = show a ++ show b ++ show c ++ toNum xs
+
</haskell>
</haskell>
Line 264: Line 166:
Solution:
Solution:
<haskell>
<haskell>
-
import Data.Ratio
+
{-phi(n) = n*(1-1/p1)*(1-1/p2)*...*(1-1/pn)
-
import Data.List
+
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
-
primePowerFactors n = rle (takeFactors n primes)
+
-}
-
where rle = map (\xs -> (head xs, length xs)) . group
+
primes=[2,3,5,7,11,13,17,19,23]
-
takeFactors n (p:ps)
+
problem_69=
-
| n == 1 = []
+
maximum [c|
-
| p * p > n = [n]
+
a<-[1..length primes],
-
| n `mod` p == 0 = p : takeFactors (n `div` p) (p:ps)
+
let b=take a primes,
-
| otherwise = takeFactors n ps
+
let c=product b,
-
 
+
c<10^6
-
eulerTotient n = product (map (\(p,i) -> p^(i-1) * (p-1)) factors)
+
]
-
where factors = primePowerFactors n
+
-
 
+
-
problem_69 =
+
-
snd . maximum . map
+
-
(\n -> (n % eulerTotient n, n)) $
+
-
[1..1000000]
+
</haskell>
</haskell>
Line 291: Line 187:
Solution:
Solution:
<haskell>
<haskell>
-
import Data.List (minimumBy, group, sort)
+
import Data.List
-
 
+
isPerm a b = (show a) \\ (show b)==[]
-
primes :: [Int]
+
flsqr n x=x<(floor.sqrt.fromInteger) n
-
primes = 2 : filter (l1 . primeFactors) [3,5..]
+
pairs n1 =
 +
maximum[m|a<-gena ,b<-genb,let m=a*b,n>m,isPerm m$ m-a-b+1]
where
where
-
l1 (_:[]) = True
+
n=fromInteger n1
-
l1 _ = False
+
gena = dropWhile (flsqr n)$ takeWhile (flsqr (2*n)) primes
-
 
+
genb = dropWhile (flsqr (div n 2))$ takeWhile (flsqr n) primes
-
primeFactors :: Int -> [Int]
+
-
primeFactors n = factor n primes
+
-
where
+
-
factor _ [] = []
+
-
factor m (p:ps) | p*p > m = [m]
+
-
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
+
-
| otherwise = factor m ps
+
-
 
+
-
primePowerFactors :: Int -> [(Int, Int)]
+
-
primePowerFactors n =
+
-
map (\x -> (head x, length x)) $ (group . primeFactors) n
+
-
 
+
-
phi :: Int -> Int
+
-
phi n = product (map f $ primePowerFactors n)
+
-
where
+
-
f (p, l) = (p-1)*(p^(l-1))
+
-
 
+
-
isPermutation :: (Show a) => a -> a -> Bool
+
-
isPermutation a b = (sort $ show a) == (sort $ show b)
+
-
 
+
-
phiPerms :: [(Int, Int)]
+
-
phiPerms = [(n, p)| n <- [2..10000000], let p = phi n, isPermutation n p]
+
-
problem_70 :: Int
+
problem_70= pairs (10^7)
-
problem_70 =
+
-
fst $ minimumBy
+
-
(\(a,b) (a',b') -> compare (fromIntegral a/fromIntegral b)
+
-
(fromIntegral a'/fromIntegral b')) phiPerms
+
</haskell>
</haskell>

Revision as of 13:12, 19 January 2008

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
d = findIndex (==(head (head c))) b
problem_62 = (toInteger (fromJust 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 id $ map 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) + fromIntegral n ) / fromIntegral d)
    a = n - d * m
    rest = if d == 1 && n /= 0
           then []
           else 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 = if y < x then f y else 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 = 
    concat $ map (\(x:xs) -> map (x:) (permute xs))
    (take (length list) 
    (unfoldr (\x -> Just (x, tail x ++ [head x])) list))
problem_68 = 
    maximum $ map (concat . map show) poel 
    where
    gon68 = [1..10]
    knip = (length gon68) `div` 2
    (is,es) = splitAt knip gon68
    extnodes = map (\x -> [head es]++x) $ permute $ tail es
    intnodes = map (\(p:ps) -> zipWith (\ x y -> [x]++[y])
        (p:ps) (ps++[p])) $ permute is
    poel = [ concat hs | hs <- [ zipWith (\x y -> [x]++y) uitsteeksels organen |
        uitsteeksels <- extnodes, organen <- intnodes ],
        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|
    a<-[1..length primes],
    let b=take a 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
isPerm a b = (show a) \\ (show b)==[]
flsqr n x=x<(floor.sqrt.fromInteger) n
pairs n1 = 
    maximum[m|a<-gena ,b<-genb,let m=a*b,n>m,isPerm m$ m-a-b+1]
    where
    n=fromInteger n1
    gena = dropWhile (flsqr n)$  takeWhile (flsqr (2*n))  primes
    genb = dropWhile (flsqr (div n 2))$  takeWhile (flsqr n)  primes
 
problem_70= pairs (10^7)
Retrieved from "http://www.haskell.org/haskellwiki/Euler_problems/61_to_70"