Personal tools

Euler problems/71 to 80

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
m
 
(25 intermediate revisions by 10 users not shown)
Line 1: Line 1:
[[Category:Programming exercise spoilers]]
+
== [http://projecteuler.net/index.php?section=view&id=71 Problem 71] ==
== [http://projecteuler.net/index.php?section=problems&id=71 Problem 71] ==
 
 
Listing reduced proper fractions in ascending order of size.
 
Listing reduced proper fractions in ascending order of size.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_71 = undefined
+
-- http://mathworld.wolfram.com/FareySequence.html
  +
import Data.Ratio ((%), numerator,denominator)
  +
fareySeq a b
  +
|da2<=10^6=fareySeq a1 b
  +
|otherwise=na
  +
where
  +
na=numerator a
  +
nb=numerator b
  +
da=denominator a
  +
db=denominator b
  +
a1=(na+nb)%(da+db)
  +
da2=denominator a1
  +
problem_71=fareySeq (0%1) (3%7)
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=72 Problem 72] ==
+
== [http://projecteuler.net/index.php?section=view&id=72 Problem 72] ==
 
How many elements would be contained in the set of reduced proper fractions for d ≤ 1,000,000?
 
How many elements would be contained in the set of reduced proper fractions for d ≤ 1,000,000?
   
 
Solution:
 
Solution:
  +
  +
Using the [http://mathworld.wolfram.com/FareySequence.html Farey Sequence] method, the solution is the sum of phi (n) from 1 to 1000000.
 
<haskell>
 
<haskell>
problem_72 = undefined
+
groups=1000
  +
eulerTotient n = product (map (\(p,i) -> p^(i-1) * (p-1)) factors)
  +
where factors = fstfac n
  +
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
  +
p72 n= sum [eulerTotient x|x <- [groups*n+1..groups*(n+1)]]
  +
problem_72 = sum [p72 x|x <- [0..999]]
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=73 Problem 73] ==
+
== [http://projecteuler.net/index.php?section=view&id=73 Problem 73] ==
 
How many fractions lie between 1/3 and 1/2 in a sorted set of reduced proper fractions?
 
How many fractions lie between 1/3 and 1/2 in a sorted set of reduced proper fractions?
   
 
Solution:
 
Solution:
  +
  +
If you haven't done so already, read about Farey sequences in Wikipedia
  +
http://en.wikipedia.org/wiki/Farey_sequence, where you will learn about
  +
mediants. Then divide and conquer. The number of Farey ratios between
  +
(a, b) is 1 + the number between (a, mediant a b) + the number between
  +
(mediant a b, b). Henrylaxen 2008-03-04
  +
 
<haskell>
 
<haskell>
problem_73 = undefined
+
import Data.Ratio
  +
  +
mediant :: (Integral a) => Ratio a -> Ratio a -> Ratio a
  +
mediant f1 f2 = (numerator f1 + numerator f2) %
  +
(denominator f1 + denominator f2)
  +
fareyCount :: (Integral a, Num t) => a -> (Ratio a, Ratio a) -> t
  +
fareyCount n (a,b) =
  +
let c = mediant a b
  +
in if (denominator c > n) then 0 else
  +
1 + (fareyCount n (a,c)) + (fareyCount n (c,b))
  +
  +
problem_73 :: Integer
  +
problem_73 = fareyCount 10000 (1%3,1%2)
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=74 Problem 74] ==
+
  +
== [http://projecteuler.net/index.php?section=view&id=74 Problem 74] ==
 
Determine the number of factorial chains that contain exactly sixty non-repeating terms.
 
Determine the number of factorial chains that contain exactly sixty non-repeating terms.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_74 = undefined
+
import Data.List
  +
explode 0 = []
  +
explode n = n `mod` 10 : explode (n `quot` 10)
  +
  +
chain 2 = 1
  +
chain 1 = 1
  +
chain 145 = 1
  +
chain 40585 = 1
  +
chain 169 = 3
  +
chain 363601 = 3
  +
chain 1454 = 3
  +
chain 871 = 2
  +
chain 45361 = 2
  +
chain 872 = 2
  +
chain 45362 = 2
  +
chain x = 1 + chain (sumFactDigits x)
  +
makeIncreas 1 minnum = [[a]|a<-[minnum..9]]
  +
makeIncreas digits minnum = [a:b|a<-[minnum ..9],b<-makeIncreas (digits-1) a]
  +
p74=
  +
sum[div p6 $countNum a|
  +
a<-tail$makeIncreas 6 1,
  +
let k=digitToN a,
  +
chain k==60
  +
]
  +
where
  +
p6=facts!! 6
  +
sumFactDigits = foldl' (\a b -> a + facts !! b) 0 . explode
  +
factorial n = if n == 0 then 1 else n * factorial (n - 1)
  +
digitToN = foldl' (\a b -> 10*a + b) 0 .dropWhile (==0)
  +
facts = scanl (*) 1 [1..9]
  +
countNum xs=ys
  +
where
  +
ys=product$map (factorial.length)$group xs
  +
problem_74= length[k|k<-[1..9999],chain k==60]+p74
  +
test = print $ [a|a<-tail$makeIncreas 6 0,let k=digitToN a,chain k==60]
 
</haskell>
 
</haskell>
+
== [http://projecteuler.net/index.php?section=view&id=75 Problem 75] ==
== [http://projecteuler.net/index.php?section=problems&id=75 Problem 75] ==
 
 
Find the number of different lengths of wire can that can form a right angle triangle in only one way.
 
Find the number of different lengths of wire can that can form a right angle triangle in only one way.
   
 
Solution:
 
Solution:
This is only slightly harder than [[Euler problems/31 to 40#39|problem 39]]. The search condition is simpler but the search space is larger.
 
 
<haskell>
 
<haskell>
problem_75 = length . filter ((== 1) . length) $ group perims
+
import Data.Array
where perims = sort [scale*p | p <- pTriples, scale <- [1..10^6 `div` p]]
+
pTriples = [p |
+
triangs :: [Int]
n <- [1..1000],
+
triangs = [p | n <- [2..1000],
m <- [n+1..1000],
+
m <- [1..n-1],
even n || even m,
+
gcd m n == 1,
gcd n m == 1,
+
odd (m+n),
let a = m^2 - n^2,
+
let p = 2 * (n^2 + m*n),
let b = 2*m*n,
+
p <= 2*10^6]
let c = m^2 + n^2,
+
let p = a + b + c,
+
problem_75 :: Int
p <= 10^6]
+
problem_75 = length
  +
$ filter (\(_, c) -> c == 1)
  +
$ assocs
  +
$ (\ns -> accumArray (+) 0 (1, 2*10^6) [(n, 1) | n <- ns, inRange (1, 2*10^6) n])
  +
$ concatMap (\n -> takeWhile (<=2*10^6) [n,2*n..]) triangs
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=76 Problem 76] ==
+
== [http://projecteuler.net/index.php?section=view&id=76 Problem 76] ==
 
How many different ways can one hundred be written as a sum of at least two positive integers?
 
How many different ways can one hundred be written as a sum of at least two positive integers?
   
 
Solution:
 
Solution:
  +
  +
Here is a simpler solution: For each n, we create the list of the number of partitions of n
  +
whose lowest number is i, for i=1..n. We build up the list of these lists for n=0..100.
 
<haskell>
 
<haskell>
problem_76 = undefined
+
build x = (map sum (zipWith drop [0..] x) ++ [1]) : x
  +
problem_76 = (sum $ head $ iterate build [] !! 100) - 1
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=77 Problem 77] ==
+
== [http://projecteuler.net/index.php?section=view&id=77 Problem 77] ==
 
What is the first value which can be written as the sum of primes in over five thousand different ways?
 
What is the first value which can be written as the sum of primes in over five thousand different ways?
   
 
Solution:
 
Solution:
  +
  +
Brute force but still finds the solution in less than one second.
 
<haskell>
 
<haskell>
problem_77 = undefined
+
counter = foldl (\without p ->
  +
let (poor,rich) = splitAt p without
  +
with = poor ++
  +
zipWith (+) with rich
  +
in with
  +
) (1 : repeat 0)
  +
  +
problem_77 =
  +
find ((>5000) . (ways !!)) $ [1..]
  +
where
  +
ways = counter $ take 100 primes
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=78 Problem 78] ==
+
== [http://projecteuler.net/index.php?section=view&id=78 Problem 78] ==
 
Investigating the number of ways in which coins can be separated into piles.
 
Investigating the number of ways in which coins can be separated into piles.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_78 = undefined
+
import Data.Array
  +
  +
partitions :: Array Int Integer
  +
partitions =
  +
array (0,1000000) $
  +
(0,1) :
  +
[(n,sum [s * partitions ! p|
  +
(s,p) <- zip signs $ parts n])|
  +
n <- [1..1000000]]
  +
where
  +
signs = cycle [1,1,(-1),(-1)]
  +
suite = map penta $ concat [[n,(-n)]|n <- [1..]]
  +
penta n = n*(3*n - 1) `div` 2
  +
parts n = takeWhile (>= 0) [n-x| x <- suite]
  +
  +
problem_78 :: Int
  +
problem_78 =
  +
head $ filter (\x -> (partitions ! x) `mod` 1000000 == 0) [1..]
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=79 Problem 79] ==
+
== [http://projecteuler.net/index.php?section=view&id=79 Problem 79] ==
 
By analysing a user's login attempts, can you determine the secret numeric passcode?
 
By analysing a user's login attempts, can you determine the secret numeric passcode?
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_79 = undefined
+
import Data.Char (digitToInt, intToDigit)
  +
import Data.Graph (buildG, topSort)
  +
import Data.List (intersect)
  +
  +
p79 file=
  +
(+0)$read . intersect graphWalk $ usedDigits
  +
where
  +
usedDigits = intersect "0123456789" $ file
  +
edges = concatMap (edgePair . map digitToInt) . words $ file
  +
graphWalk = map intToDigit . topSort . buildG (0, 9) $ edges
  +
edgePair [x, y, z] = [(x, y), (y, z)]
  +
edgePair _ = undefined
  +
  +
problem_79 = do
  +
f<-readFile "keylog.txt"
  +
print $p79 f
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&id=80 Problem 80] ==
+
== [http://projecteuler.net/index.php?section=view&id=80 Problem 80] ==
 
Calculating the digital sum of the decimal digits of irrational square roots.
 
Calculating the digital sum of the decimal digits of irrational square roots.
   
Solution:
+
This solution uses binary search to find the square root of a large Integer:
 
<haskell>
 
<haskell>
problem_80 = undefined
+
import Data.Char (digitToInt)
</haskell>
 
   
[[Category:Tutorials]]
+
intSqrt :: Integer -> Integer
[[Category:Code]]
+
intSqrt n = bsearch 1 n
  +
where
  +
bsearch l u = let m = (l+u) `div` 2
  +
m2 = m^2
  +
in if u <= l
  +
then m
  +
else if m2 < n
  +
then bsearch (m+1) u
  +
else bsearch l m
  +
  +
problem_80 :: Int
  +
problem_80 = sum [f r | a <- [1..100],
  +
let x = a * e,
  +
let r = intSqrt x,
  +
r*r /= x]
  +
where
  +
e = 10^202
  +
f = sum . take 100 . map digitToInt . show
  +
</haskell>

Latest revision as of 10:37, 13 December 2009

Contents

[edit] 1 Problem 71

Listing reduced proper fractions in ascending order of size.

Solution:

-- http://mathworld.wolfram.com/FareySequence.html 
import Data.Ratio ((%), numerator,denominator)
fareySeq a b
    |da2<=10^6=fareySeq a1 b
    |otherwise=na
    where
    na=numerator a
    nb=numerator b
    da=denominator a
    db=denominator b
    a1=(na+nb)%(da+db)
    da2=denominator a1
problem_71=fareySeq (0%1) (3%7)

[edit] 2 Problem 72

How many elements would be contained in the set of reduced proper fractions for d ≤ 1,000,000?

Solution:

Using the Farey Sequence method, the solution is the sum of phi (n) from 1 to 1000000.

groups=1000
eulerTotient n = product (map (\(p,i) -> p^(i-1) * (p-1)) factors)
    where factors = fstfac n
fstfac x = [(head a ,length a)|a<-group$primeFactors x] 
p72 n= sum [eulerTotient x|x <- [groups*n+1..groups*(n+1)]]
problem_72 = sum [p72 x|x <- [0..999]]

[edit] 3 Problem 73

How many fractions lie between 1/3 and 1/2 in a sorted set of reduced proper fractions?

Solution:

If you haven't done so already, read about Farey sequences in Wikipedia http://en.wikipedia.org/wiki/Farey_sequence, where you will learn about mediants. Then divide and conquer. The number of Farey ratios between (a, b) is 1 + the number between (a, mediant a b) + the number between (mediant a b, b). Henrylaxen 2008-03-04

import Data.Ratio
 
mediant :: (Integral a) => Ratio a -> Ratio a -> Ratio a
mediant f1 f2 = (numerator f1 + numerator f2) % 
                (denominator f1 + denominator f2)
fareyCount :: (Integral a, Num t) => a -> (Ratio a, Ratio a) -> t
fareyCount n (a,b) =
  let c = mediant a b
  in  if (denominator c > n) then 0 else 
         1 + (fareyCount n (a,c)) + (fareyCount n (c,b))
 
problem_73 :: Integer
problem_73 =  fareyCount 10000   (1%3,1%2)


[edit] 4 Problem 74

Determine the number of factorial chains that contain exactly sixty non-repeating terms.

Solution:

import Data.List
explode 0 = []
explode n = n `mod` 10 : explode (n `quot` 10)
 
chain 2    = 1
chain 1    = 1
chain 145    = 1
chain 40585    = 1
chain 169    = 3
chain 363601 = 3
chain 1454   = 3
chain 871    = 2
chain 45361  = 2
chain 872    = 2
chain 45362  = 2
chain x = 1 + chain (sumFactDigits x)
makeIncreas 1 minnum  = [[a]|a<-[minnum..9]]
makeIncreas digits minnum  = [a:b|a<-[minnum ..9],b<-makeIncreas (digits-1) a]
p74=
    sum[div p6 $countNum a|
    a<-tail$makeIncreas  6 1,
    let k=digitToN a,
    chain k==60
    ]
    where
    p6=facts!! 6
sumFactDigits = foldl' (\a b -> a + facts !! b) 0 . explode
factorial n = if n == 0 then 1 else n * factorial (n - 1)
digitToN = foldl' (\a b -> 10*a + b) 0 .dropWhile (==0)
facts = scanl (*) 1 [1..9]
countNum xs=ys
    where
    ys=product$map (factorial.length)$group xs 
problem_74= length[k|k<-[1..9999],chain k==60]+p74
test = print $ [a|a<-tail$makeIncreas 6 0,let k=digitToN a,chain k==60]

[edit] 5 Problem 75

Find the number of different lengths of wire can that can form a right angle triangle in only one way.

Solution:

import Data.Array
 
triangs :: [Int]
triangs = [p | n <- [2..1000],
               m <- [1..n-1],
               gcd m n == 1,
               odd (m+n),
               let p = 2 * (n^2 + m*n),
               p <= 2*10^6]
 
problem_75 :: Int
problem_75 = length
       $ filter (\(_, c) -> c == 1)
       $ assocs
       $ (\ns -> accumArray (+) 0 (1, 2*10^6) [(n, 1) | n <- ns, inRange (1, 2*10^6) n])
       $ concatMap (\n -> takeWhile (<=2*10^6) [n,2*n..]) triangs

[edit] 6 Problem 76

How many different ways can one hundred be written as a sum of at least two positive integers?

Solution:

Here is a simpler solution: For each n, we create the list of the number of partitions of n whose lowest number is i, for i=1..n. We build up the list of these lists for n=0..100.

build x = (map sum (zipWith drop [0..] x) ++ [1]) : x
problem_76 = (sum $ head $ iterate build [] !! 100) - 1

[edit] 7 Problem 77

What is the first value which can be written as the sum of primes in over five thousand different ways?

Solution:

Brute force but still finds the solution in less than one second.

counter = foldl (\without p ->
                     let (poor,rich) = splitAt p without
                         with = poor ++ 
                                zipWith (+) with rich
                     in with
                ) (1 : repeat 0)
 
problem_77 =  
    find ((>5000) . (ways !!)) $ [1..]
    where
    ways = counter $ take 100 primes

[edit] 8 Problem 78

Investigating the number of ways in which coins can be separated into piles.

Solution:

import Data.Array
 
partitions :: Array Int Integer
partitions = 
    array (0,1000000) $ 
    (0,1) : 
    [(n,sum [s * partitions ! p|
    (s,p) <- zip signs $ parts n])|
    n <- [1..1000000]]
    where
        signs = cycle [1,1,(-1),(-1)]
        suite = map penta $ concat [[n,(-n)]|n <- [1..]]
        penta n = n*(3*n - 1) `div` 2
        parts n = takeWhile (>= 0) [n-x| x <- suite]
 
problem_78 :: Int
problem_78 = 
    head $ filter (\x -> (partitions ! x) `mod` 1000000 == 0) [1..]

[edit] 9 Problem 79

By analysing a user's login attempts, can you determine the secret numeric passcode?

Solution:

import Data.Char (digitToInt, intToDigit)
import Data.Graph (buildG, topSort)
import Data.List (intersect)
 
p79 file= 
    (+0)$read . intersect graphWalk $ usedDigits
    where
    usedDigits = intersect "0123456789" $ file
    edges = concatMap (edgePair . map digitToInt) . words $ file
    graphWalk = map intToDigit . topSort . buildG (0, 9) $ edges
    edgePair [x, y, z] = [(x, y), (y, z)]
    edgePair _         = undefined
 
problem_79 = do
    f<-readFile  "keylog.txt"
    print $p79 f

[edit] 10 Problem 80

Calculating the digital sum of the decimal digits of irrational square roots.

This solution uses binary search to find the square root of a large Integer:

import Data.Char (digitToInt)
 
intSqrt :: Integer -> Integer
intSqrt n = bsearch 1 n
    where
      bsearch l u = let m = (l+u) `div` 2
                        m2 = m^2
                    in if u <= l
                       then m
                       else if m2 < n
                            then bsearch (m+1) u
                            else bsearch l m
 
problem_80 :: Int
problem_80 = sum [f r | a <- [1..100],
                        let x = a * e,
                        let r = intSqrt x,
                        r*r /= x]
    where
      e = 10^202
      f = sum . take 100 . map digitToInt . show