Personal tools

Euler problems/61 to 70

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(Problem 70)
 
(14 intermediate revisions by 5 users not shown)
Line 1: Line 1:
[[Category:Programming exercise spoilers]]
+
== [http://projecteuler.net/index.php?section=problems&id=61 Problem 61] ==
== [http://projecteuler.net/index.php?section=view&id=61 Problem 61] ==
 
 
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property.
 
Find the sum of the only set of six 4-digit figurate numbers with a cyclic property.
   
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 [triangle4, square4, pentagonal4, hexagonal4, heptagonal4, octagonal4]
+
$ scanl (+) 1 [m-1,2*m-3..],
a <- l1
+
1010 < x, x `mod` 100 > 9]
let m = filter (g a) l2
+
b <- m
+
problem_61 = sum $ map snd $ head $ concatMap (figurates 3) $ permute [4..8]
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>
   
== [http://projecteuler.net/index.php?section=view&id=62 Problem 62] ==
+
== [http://projecteuler.net/index.php?section=problems&id=62 Problem 62] ==
 
Find the smallest cube for which exactly five permutations of its digits are cube.
 
Find the smallest cube for which exactly five permutations of its digits are cube.
   
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 = f3 $ head $ head $ sortBy shf $ filter l5 $ groupBy g $ sortBy ss $ map sd cubes
+
c = filter ((==5) . length) . group . sort $ b
where
+
Just d = elemIndex (head (head c)) b
sd (a, b) = (a, sort b)
+
problem_62 = toInteger d^3
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>
   
== [http://projecteuler.net/index.php?section=view&id=63 Problem 63] ==
+
== [http://projecteuler.net/index.php?section=problems&id=63 Problem 63] ==
 
How many n-digit positive integers exist which are also an nth power?
 
How many n-digit positive integers exist which are also an nth power?
   
 
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 = length . concatMap (takeWhile (\(n,p) -> n == nDigits p))
+
problem_63=length[x^y|x<-[1..9],y<-[1..22],y==(length$show$x^y)]
$ [powers d | d <- [1..9]]
 
where powers d = [(n, d^n) | n <- [1..]]
 
nDigits n = length (show n)
 
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=64 Problem 64] ==
+
== [http://projecteuler.net/index.php?section=problems&id=64 Problem 64] ==
 
How many continued fractions for N ≤ 10000 have an odd period?
 
How many continued fractions for N ≤ 10000 have an odd period?
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.List (findIndex)
+
import Data.List
+
fraction n = (a0, 1, (-a0)) : nextDigits n 1 (-a0)
+
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
 
where
a0 = firstDigit n
+
m = (truncate (sqrt (fromIntegral r)) + n) `div` d
+
a = n - d * m
nextDigits n num den
+
rest | d == 1 && n /= 0 = []
| n - (den^2) == 0 = []
+
| otherwise = cont r (-a) ((r - a ^ 2) `div` d)
| 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]
 
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=65 Problem 65] ==
+
== [http://projecteuler.net/index.php?section=problems&id=65 Problem 65] ==
 
Find the sum of digits in the numerator of the 100th convergent of the continued fraction for e.
 
Find the sum of digits in the numerator of the 100th convergent of the continued fraction for e.
   
 
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>
   
== [http://projecteuler.net/index.php?section=view&id=66 Problem 66] ==
+
== [http://projecteuler.net/index.php?section=problems&id=66 Problem 66] ==
 
Investigate the Diophantine equation x<sup>2</sup> − Dy<sup>2</sup> = 1.
 
Investigate the Diophantine equation x<sup>2</sup> − Dy<sup>2</sup> = 1.
   
 
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 | 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
  +
]
   
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>
   
== [http://projecteuler.net/index.php?section=view&id=67 Problem 67] ==
+
== [http://projecteuler.net/index.php?section=problems&id=67 Problem 67] ==
 
Using an efficient algorithm find the maximal sum in the triangle?
 
Using an efficient algorithm find the maximal sum in the triangle?
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import System.Process
+
problem_67 = readFile "triangle.txt" >>= print . solve . parse
import IO
+
parse = map (map read . words) . lines
+
solve = head . foldr1 step
slurpURL url = do
+
step [] [z] = [z]
(_,out,_,_) <- runInteractiveCommand $ "curl " ++ url
+
step (x:xs) (y:z:zs) = x + max y z : step xs (z:zs)
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
 
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=68 Problem 68] ==
+
== [http://projecteuler.net/index.php?section=problems&id=68 Problem 68] ==
 
What is the maximum 16-digit string for a "magic" 5-gon ring?
 
What is the maximum 16-digit string for a "magic" 5-gon ring?
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.List (delete, group, sort)
+
import Data.List
+
permute [] = [[]]
numberSets :: Int -> [(Int, Int, Int)]
+
permute list =
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]
+
concatMap (\(x:xs) -> map (x:) (permute xs))
+
(take (length list)
nextSets :: (Int, Int, Int) -> [(Int, Int, Int)]
+
(unfoldr (\l@(x:xs) -> Just (l, xs ++ [x])) list))
nextSets (a,b,c) = filter f $ numberSets s
+
problem_68 =
where
+
maximum $ map (concatMap show) poel
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
 
where
toNum [] = []
+
gon68 = [1..10]
toNum ((a,b,c):xs) = show a ++ show b ++ show c ++ toNum xs
+
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 ]
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=69 Problem 69] ==
+
== [http://projecteuler.net/index.php?section=problems&id=69 Problem 69] ==
 
Find the value of n ≤ 1,000,000 for which n/φ(n) is a maximum.
 
Find the value of n ≤ 1,000,000 for which n/φ(n) is a maximum.
   
 
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]
+
b<-tail $ inits primes,
| n `mod` p == 0 = p : takeFactors (n `div` p) (p:ps)
+
let c=product b,
| otherwise = takeFactors n ps
+
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>
   
 
Note: credit for arithmetic functions is due to [http://www.polyomino.f2s.com/ David Amos].
 
Note: credit for arithmetic functions is due to [http://www.polyomino.f2s.com/ David Amos].
   
== [http://projecteuler.net/index.php?section=view&id=70 Problem 70] ==
+
== [http://projecteuler.net/index.php?section=problems&id=70 Problem 70] ==
 
Investigate values of n for which φ(n) is a permutation of n.
 
Investigate values of n for which φ(n) is a permutation of n.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.List (minimumBy, group, sort)
+
import Data.List
+
import Data.Function
primes :: [Int]
+
isPerm a b = null $ show a \\ show b
primes = 2 : filter (l1 . primeFactors) [3,5..]
+
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
 
where
l1 (_:[]) = True
+
n=fromInteger n1
l1 _ = False
+
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)
   
primeFactors :: Int -> [Int]
+
problem_70= pairs (10^7)
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
 
 
</haskell>
 
</haskell>
 
[[Category:Tutorials]]
 
[[Category:Code]]
 

Latest revision as of 18:36, 9 September 2011

Contents

[edit] 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]

[edit] 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
Just d = elemIndex (head (head c)) b
problem_62 = toInteger d^3

[edit] 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)]

[edit] 4 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)

[edit] 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

[edit] 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 | 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)

[edit] 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)

[edit] 8 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 ]

[edit] 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|
    b<-tail $ inits primes,
    let c=product b,
    c<10^6
    ]

Note: credit for arithmetic functions is due to David Amos.

[edit] 10 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)