# Euler problems/61 to 70

### From HaskellWiki

## 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 triangle = [n*(n+1)`div`2 | n <- [1..]] square = [n^2 | n <- [1..]] pentagonal = [n*(3*n-1)`div`2 | n <- [1..]] hexagonal = [n*(2*n-1) | n <- [1..]] heptagonal = [n*(5*n-3)`div`2 | n <- [1..]] octagonal = [n*(3*n-2) | n <- [1..]] triangle4 = fourDigs triangle square4 = fourDigs square pentagonal4 = fourDigs pentagonal hexagonal4 = fourDigs hexagonal heptagonal4 = fourDigs heptagonal octagonal4 = fourDigs octagonal fourDigs = takeWhile (<10000) . dropWhile (<1000) solve = do (l1:l2:l3:l4:l5:l6:_) <- permute [triangle4, square4, pentagonal4, hexagonal4, heptagonal4, octagonal4] a <- l1 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

## 2 Problem 62

Find the smallest cube for which exactly five permutations of its digits are cube.

Solution:

import Data.List cubes = [(x, show $ x^3) | x <- [1..100000]] problem_62 = f3 $ head $ head $ sortBy shf $ filter l5 $ groupBy g $ sortBy ss $ map sd cubes 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

## 3 Problem 63

How many n-digit positive integers exist which are also an nth power?

Solution:
Since d^{n} has at least n+1 digits for any d≥10, we need only consider 1 through 9. If d^{n} 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^{n} for each d in {1,...,9}, trying n=1,2,... and stopping when d^{n} has fewer than n digits.

problem_63 = 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)

## 4 Problem 64

How many continued fractions for N ≤ 10000 have an odd period?

Solution:

import Data.List (findIndex) fraction n = (a0, 1, (-a0)) : nextDigits n 1 (-a0) where a0 = firstDigit n nextDigits n num den | n - (den^2) == 0 = [] | otherwise = (an, den', num') : nextDigits n den' num' 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]

## 5 Problem 65

Find the sum of digits in the numerator of the 100th convergent of the continued fraction for e.

Solution:

import Data.Ratio problem_65 = dsum . numerator . contFrac . 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

## 6 Problem 66

Investigate the Diophantine equation x^{2} − Dy^{2} = 1.

Solution:

Problem solved using the continuous fractions method (reused from problem 64).

import Data.List (inits, maximumBy) import Data.Ratio ((%), numerator, denominator) fraction :: Integer -> [Integer] fraction n = a0 : nextDigits n 1 (-a0) where a0 = firstDigit n firstDigit :: Integer -> Integer firstDigit n = floor $ sqrt $ fromInteger n nextDigits :: Integer -> Integer -> Integer -> [Integer] nextDigits n num den | n - (den^2) == 0 = [] | otherwise = an : nextDigits n den' num' where a0 = firstDigit n den' = (n - (den^2)) `div` num an = (a0 + abs den) `div` den' num' = abs den - (an * den') nonSquares :: [Integer] 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

## 7 Problem 67

Using an efficient algorithm find the maximal sum in the triangle?

Solution:

problem_67 = do src <- readFile "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

## 8 Problem 68

What is the maximum 16-digit string for a "magic" 5-gon ring?

Solution:

import Data.List (delete, group, sort) numberSets :: Int -> [(Int, Int, Int)] numberSets n = [(a,b,c)| a <- [1..10], b <- delete a [1..10], let c = n - a - b, c > 0, c < 11, a /= c, b /= c] nextSets :: (Int, Int, Int) -> [(Int, Int, Int)] nextSets (a,b,c) = filter f $ numberSets s where s = a + b + c f x = follows (a, b, c) x follows :: (Int, Int, Int) -> (Int, Int, Int) -> Bool follows (_,_,c) (_,b',_) = c == b' lowest :: (Ord a) => [a] -> [a] lowest xs = minimum $ take 6 $ iterate rotate xs where 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

## 9 Problem 69

Find the value of n ≤ 1,000,000 for which n/φ(n) is a maximum.

Solution:

import Data.Ratio import Data.List primePowerFactors n = rle (takeFactors n primes) where rle = map (\xs -> (head xs, length xs)) . group takeFactors n (p:ps) | n == 1 = [] | p * p > n = [n] | n `mod` p == 0 = p : takeFactors (n `div` p) (p:ps) | otherwise = takeFactors n ps 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]

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 (minimumBy, group, sort) primes :: [Int] primes = 2 : filter (l1 . primeFactors) [3,5..] where l1 (_:[]) = True l1 _ = False 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 = fst $ minimumBy (\(a,b) (a',b') -> compare (fromIntegral a/fromIntegral b) (fromIntegral a'/fromIntegral b')) phiPerms