# Euler problems/61 to 70

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)

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

## 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
problem_62 = toInteger d^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)]
```

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

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

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

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

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

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

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