# Difference between revisions of "Euler problems/61 to 70"

## 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 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
```

## Problem 63

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

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

## 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]
```

## 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
```

## Problem 66

Investigate the Diophantine equation x2 − Dy2 = 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
```

## Problem 67

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

Solution:

```import System.Process
import IO

slurpURL url = do
(_,out,_,_) <- runInteractiveCommand \$ "curl " ++ url
hGetContents out

problem_67 = do
src <- slurpURL "http://projecteuler.net/project/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
```

## 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
```

## 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.

## 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
```