Personal tools

Euler problems/61 to 70

From HaskellWiki

< Euler problems(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 35: 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 47: 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 57: 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 73: Line 72:
 
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 82: Line 87:
   
 
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 113: Line 116:
 
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 125: Line 128:
 
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 150: Line 153:
 
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 171: Line 174:
 
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)