Euler problems/11 to 20
From HaskellWiki
Jim Burton (Talk  contribs) m 
(→Problem 14: fourth solution does not memoize) 

(38 intermediate revisions by 14 users not shown)  
Line 1:  Line 1:  
−  [[Category:Programming exercise spoilers]] 

== [http://projecteuler.net/index.php?section=problems&id=11 Problem 11] == 
== [http://projecteuler.net/index.php?section=problems&id=11 Problem 11] == 

−  What is the greatest product of four numbers on the same straight line in the [http://projecteuler.net/index.php?section=view&id=11 20 by 20 grid]? 
+  What is the greatest product of four numbers on the same straight line in the [http://projecteuler.net/index.php?section=problems&id=11 20 by 20 grid]? 
Solution: 
Solution: 

+  using Array and Arrows, for fun : 

<haskell> 
<haskell> 

−  problem_11 = undefined 
+  import Control.Arrow 
+  import Data.Array 

+  
+  input :: String > Array (Int,Int) Int 

+  input = listArray ((1,1),(20,20)) . map read . words 

+  
+  senses = [(+1) *** id,(+1) *** (+1), id *** (+1), (+1) *** (\n > n  1)] 

+  
+  inArray a i = inRange (bounds a) i 

+  
+  prods :: Array (Int, Int) Int > [Int] 

+  prods a = [product xs  i < range $ bounds a, 

+  s < senses, 

+  let is = take 4 $ iterate s i, 

+  all (inArray a) is, 

+  let xs = map (a!) is] 

+  main = print . maximum . prods . input =<< getContents 

</haskell> 
</haskell> 

Line 13:  Line 13:  
Solution: 
Solution: 

<haskell> 
<haskell> 

+  primeFactors in problem_3 

problem_12 = head $ filter ((> 500) . nDivisors) triangleNumbers 
problem_12 = head $ filter ((> 500) . nDivisors) triangleNumbers 

−  where triangleNumbers = scanl1 (+) [1..] 
+  where nDivisors n = product $ map ((+1) . length) (group (primeFactors n)) 
−  nDivisors n = product $ map ((+1) . length) (group (primeFactors n)) 
+  triangleNumbers = scanl1 (+) [1..] 
−  primes = 2 : filter ((== 1) . length . primeFactors) [3,5..] 

−  primeFactors n = factor n primes 

−  where factor n (p:ps)  p*p > n = [n] 

−   n `mod` p == 0 = p : factor (n `div` p) (p:ps) 

−   otherwise = factor n ps 

</haskell> 
</haskell> 

Line 23:  Line 24:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  nums = ...  put the numbers in a list 
+  
−  problem_13 = take 10 . show . sum $ nums 
+  main = do xs < fmap (map read . lines) (readFile "p13.log") 
+  print . take 10 . show . sum $ xs 

</haskell> 
</haskell> 

Line 31:  Line 32:  
Solution: 
Solution: 

+  <haskell> 

+  import Data.List 

+  
+  problem_14 = j 1000000 where 

+  f :: Int > Integer > Int 

+  f k 1 = k 

+  f k n = f (k+1) $ if even n then div n 2 else 3*n + 1 

+  g x y = if snd x < snd y then y else x 

+  h x n = g x (n, f 1 n) 

+  j n = fst $ foldl' h (1,1) [2..n1] 

+  </haskell> 

+  
+  Faster solution, using unboxed types and parallel computation: 

<haskell> 
<haskell> 

−  p14s :: Integer > [Integer] 
+  import Control.Parallel 
−  p14s n = n : p14s' n 
+  import Data.Word 
−  where p14s' n = if n' == 1 then [1] else n' : p14s' n' 
+  
−  where n' = if even n then n `div` 2 else (3*n)+1 
+  collatzLen :: Int > Word32 > Int 
+  collatzLen c 1 = c 

+  collatzLen c n = collatzLen (c+1) $ if n `mod` 2 == 0 then n `div` 2 else 3*n+1 

+  
+  pmax x n = x `max` (collatzLen 1 n, n) 

+  
+  solve xs = foldl pmax (1,1) xs 

+  
+  main = print soln 

+  where 

+  s1 = solve [2..500000] 

+  s2 = solve [500001..1000000] 

+  soln = s2 `par` (s1 `pseq` max s1 s2) 

+  </haskell> 

+  
+  Even faster solution, using an Array to memoize length of sequences : 

+  <haskell> 

+  import Data.Array 

+  import Data.List 

+  import Data.Ord (comparing) 

+  
+  syrs n = 

+  a 

+  where 

+  a = listArray (1,n) $ 0:[1 + syr n x  x < [2..n]] 

+  syr n x = 

+  if x' <= n then a ! x' else 1 + syr n x' 

+  where 

+  x' = if even x then x `div` 2 else 3 * x + 1 

+  
+  main = 

+  print $ maximumBy (comparing snd) $ assocs $ syrs 1000000 

+  </haskell> 

+  
+  <! 

+  This is a trivial solution without any memoization, right? 

+  
+  Using a list to memoize the lengths 

+  
+  <haskell> 

+  import Data.List 

+  
+   computes the sequence for a given n 

+  l n = n:unfoldr f n where 

+  f 1 = Nothing  we're done here 

+   for reasons of speed we do div and mod in one go 

+  f n = let (d,m)=divMod n 2 in case m of 

+  0 > Just (d,d)  n was even 

+  otherwise > let k = 3*n+1 in Just (k,k)  n was odd 

+  
−  problem_14 = fst $ head $ sortBy (\(_,x) (_,y) > compare y x) [(x, length $ p14s x)  x < [1 .. 999999]] 
+  answer = foldl1' f $  computes the maximum of a list of tuples 
+   save the length of the sequence and the number generating it in a tuple 

+  [(length $! l x, x)  x < [1..1000000]] where 

+  f (a,c) (b,d)  one tuple is greater than other if the first component (=sequencelength) is greater 

+   a > b = (a,c) 

+   otherwise = (b,d) 

+  main = print answer 

</haskell> 
</haskell> 

+  > 

== [http://projecteuler.net/index.php?section=problems&id=15 Problem 15] == 
== [http://projecteuler.net/index.php?section=problems&id=15 Problem 15] == 

Line 45:  Line 61:  
Solution: 
Solution: 

+  A direct computation: 

+  <haskell> 

+  problem_15 = iterate (scanl1 (+)) (repeat 1) !! 20 !! 20 

+  </haskell> 

+  
+  Thinking about it as a problem in combinatorics: 

+  
+  Each route has exactly 40 steps, with 20 of them horizontal and 20 of 

+  them vertical. We need to count how many different ways there are of 

+  choosing which steps are horizontal and which are vertical. So we have: 

+  
<haskell> 
<haskell> 

−  problem_15 = undefined 
+  problem_15 = product [21..40] `div` product [2..20] 
</haskell> 
</haskell> 

Line 54:  Line 81:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  dsum 0 = 0 
+  import Data.Char 
−  dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d ) 
+  problem_16 = sum k 
−  +  where s = show (2^1000) 

−  problem_16 = dsum ( 2^1000 ) 
+  k = map digitToInt s 
</haskell> 
</haskell> 

Line 65:  Line 92:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−   not a very concise or beautiful solution, but food for improvements :) 
+  import Char 
−  names = concat $ 
+  one = ["one","two","three","four","five","six","seven","eight", 
−  [zip [(0, n)  n < [0..19]] 
+  "nine","ten","eleven","twelve","thirteen","fourteen","fifteen", 
−  ["", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight" 
+  "sixteen","seventeen","eighteen", "nineteen"] 
−  ,"Nine", "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen" 
+  ty = ["twenty","thirty","forty","fifty","sixty","seventy","eighty","ninety"] 
−  ,"Sixteen", "Seventeen", "Eighteen", "Nineteen"] 

−  ,zip [(1, n)  n < [0..9]] 

−  ["", "Ten", "Twenty", "Thirty", "Fourty", "Fifty", "Sixty", "Seventy" 

−  ,"Eighty", "Ninety"] 

−  ,[((2,0), "")] 

−  ,[((2, n), look (0,n) ++ " Hundred and")  n < [1..9]] 

−  ,[((3,0), "")] 

−  ,[((3, n), look (0,n) ++ " Thousand")  n < [1..9]]] 

−  look n = fromJust . lookup n $ names 
+  decompose x 
+   x == 0 = [] 

+   x < 20 = one !! (x1) 

+   x >= 20 && x < 100 = 

+  ty !! (firstDigit (x)  2) ++ decompose ( x  firstDigit (x) * 10) 

+   x < 1000 && x `mod` 100 ==0 = 

+  one !! (firstDigit (x)1) ++ "hundred" 

+   x > 100 && x <= 999 = 

+  one !! (firstDigit (x)1) ++ "hundredand" ++decompose ( x  firstDigit (x) * 100) 

+   x == 1000 = "onethousand" 

−  spell n = unwords $ if last s == "and" then init s else s 
+  where firstDigit x = digitToInt . head . show $ x 
−  where 

−  s = words . unwords $ map look digs' 

−  digs = reverse . zip [0..] . reverse . map digitToInt . show $ n 

−  digs' = case lookup 1 digs of 

−  Just 1 > 

−  let [ten,one] = filter (\(a,_) > a<=1) digs in 

−  (digs \\ [ten,one]) ++ [(0,(snd ten)*10+(snd one))] 

−  otherwise > digs 

−  problem_17 xs = sum . map (length . filter (`notElem` " ") . spell) $ xs 
+  problem_17 = length . concatMap decompose $ [1..1000] 
</haskell> 
</haskell> 

Line 84:  Line 111:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_18 = undefined 
+  problem_18 = head $ foldr1 g tri 
+  where 

+  f x y z = x + max y z 

+  g xs ys = zipWith3 f xs ys $ tail ys 

+  tri = [ 

+  [75], 

+  [95,64], 

+  [17,47,82], 

+  [18,35,87,10], 

+  [20,04,82,47,65], 

+  [19,01,23,75,03,34], 

+  [88,02,77,73,07,63,67], 

+  [99,65,04,28,06,16,70,92], 

+  [41,41,26,56,83,40,80,70,33], 

+  [41,48,72,33,47,32,37,16,94,29], 

+  [53,71,44,65,25,43,91,52,97,51,14], 

+  [70,11,33,28,77,73,17,78,39,68,17,57], 

+  [91,71,52,38,17,14,91,43,58,50,27,29,48], 

+  [63,66,04,68,89,53,67,30,73,16,69,87,40,31], 

+  [04,62,98,27,23,09,70,98,73,93,38,53,60,04,23]] 

</haskell> 
</haskell> 

== [http://projecteuler.net/index.php?section=problems&id=19 Problem 19] == 
== [http://projecteuler.net/index.php?section=problems&id=19 Problem 19] == 

−  How many Sundays fell on the first of the month during the twentieth century? 
+  You are given the following information, but you may prefer to do some research for yourself. 
+  * 1 Jan 1900 was a Monday. 

+  * Thirty days has September, 

+  * April, June and November. 

+  * All the rest have thirtyone, 

+  * Saving February alone, 

+  Which has twentyeight, rain or shine. 

+  And on leap years, twentynine. 

+  * A leap year occurs on any year evenly divisible by 4, but not on a century unless it is divisible by 400. 

+  
+  How many Sundays fell on the first of the month during the twentieth century 

+  (1 Jan 1901 to 31 Dec 2000)? 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_19 = undefined 
+  problem_19 = length . filter (== sunday) . drop 12 . take 1212 $ since1900 
−  </haskell> 
+  since1900 = scanl nextMonth monday . concat $ 
+  replicate 4 nonLeap ++ cycle (leap : replicate 3 nonLeap) 

−  == [http://projecteuler.net/index.php?section=problems&id=20 Problem 20] == 
+  nonLeap = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] 
−  Find the sum of digits in 100! 

−  Solution: 
+  leap = 31 : 29 : drop 2 nonLeap 
−  <haskell> 
+  
−  problem_20 = let fac n = product [1..n] in 
+  nextMonth x y = (x + y) `mod` 7 
−  foldr ((+) . Data.Char.digitToInt) 0 $ show $ fac 100 
+  
+  sunday = 0 

+  monday = 1 

</haskell> 
</haskell> 

−  Alternate solution, summing digits directly, which is faster than the show, digitToInt route. 
+  Here is an alternative that is simpler, but it is cheating a bit: 
<haskell> 
<haskell> 

−  dsum 0 = 0 
+  import Data.Time.Calendar 
−  dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d ) 
+  import Data.Time.Calendar.WeekDate 
−  problem_20' = dsum . product $ [ 1 .. 100 ] 
+  problem_19_v2 = length [()  y < [1901..2000], 
+  m < [1..12], 

+  let (_, _, d) = toWeekDate $ fromGregorian y m 1, 

+  d == 7] 

</haskell> 
</haskell> 

−  [[Category:Tutorials]] 
+  == [http://projecteuler.net/index.php?section=problems&id=20 Problem 20] == 
−  [[Category:Code]] 
+  Find the sum of digits in 100! 
+  
+  Solution: 

+  <haskell> 

+  problem_20 = sum $ map Char.digitToInt $ show $ product [1..100] 

+  </haskell> 
Latest revision as of 14:07, 2 December 2011
Contents 
[edit] 1 Problem 11
What is the greatest product of four numbers on the same straight line in the 20 by 20 grid?
Solution: using Array and Arrows, for fun :
import Control.Arrow import Data.Array input :: String > Array (Int,Int) Int input = listArray ((1,1),(20,20)) . map read . words senses = [(+1) *** id,(+1) *** (+1), id *** (+1), (+1) *** (\n > n  1)] inArray a i = inRange (bounds a) i prods :: Array (Int, Int) Int > [Int] prods a = [product xs  i < range $ bounds a, s < senses, let is = take 4 $ iterate s i, all (inArray a) is, let xs = map (a!) is] main = print . maximum . prods . input =<< getContents
[edit] 2 Problem 12
What is the first triangle number to have over fivehundred divisors?
Solution:
primeFactors in problem_3 problem_12 = head $ filter ((> 500) . nDivisors) triangleNumbers where nDivisors n = product $ map ((+1) . length) (group (primeFactors n)) triangleNumbers = scanl1 (+) [1..]
[edit] 3 Problem 13
Find the first ten digits of the sum of onehundred 50digit numbers.
Solution:
main = do xs < fmap (map read . lines) (readFile "p13.log") print . take 10 . show . sum $ xs
[edit] 4 Problem 14
Find the longest sequence using a starting number under one million.
Solution:
import Data.List problem_14 = j 1000000 where f :: Int > Integer > Int f k 1 = k f k n = f (k+1) $ if even n then div n 2 else 3*n + 1 g x y = if snd x < snd y then y else x h x n = g x (n, f 1 n) j n = fst $ foldl' h (1,1) [2..n1]
Faster solution, using unboxed types and parallel computation:
import Control.Parallel import Data.Word collatzLen :: Int > Word32 > Int collatzLen c 1 = c collatzLen c n = collatzLen (c+1) $ if n `mod` 2 == 0 then n `div` 2 else 3*n+1 pmax x n = x `max` (collatzLen 1 n, n) solve xs = foldl pmax (1,1) xs main = print soln where s1 = solve [2..500000] s2 = solve [500001..1000000] soln = s2 `par` (s1 `pseq` max s1 s2)
Even faster solution, using an Array to memoize length of sequences :
import Data.Array import Data.List import Data.Ord (comparing) syrs n = a where a = listArray (1,n) $ 0:[1 + syr n x  x < [2..n]] syr n x = if x' <= n then a ! x' else 1 + syr n x' where x' = if even x then x `div` 2 else 3 * x + 1 main = print $ maximumBy (comparing snd) $ assocs $ syrs 1000000
[edit] 5 Problem 15
Starting in the top left corner in a 20 by 20 grid, how many routes are there to the bottom right corner?
Solution: A direct computation:
problem_15 = iterate (scanl1 (+)) (repeat 1) !! 20 !! 20
Thinking about it as a problem in combinatorics:
Each route has exactly 40 steps, with 20 of them horizontal and 20 of them vertical. We need to count how many different ways there are of choosing which steps are horizontal and which are vertical. So we have:
problem_15 = product [21..40] `div` product [2..20]
[edit] 6 Problem 16
What is the sum of the digits of the number 2^{1000}?
Solution:
import Data.Char problem_16 = sum k where s = show (2^1000) k = map digitToInt s
[edit] 7 Problem 17
How many letters would be needed to write all the numbers in words from 1 to 1000?
Solution:
import Char one = ["one","two","three","four","five","six","seven","eight", "nine","ten","eleven","twelve","thirteen","fourteen","fifteen", "sixteen","seventeen","eighteen", "nineteen"] ty = ["twenty","thirty","forty","fifty","sixty","seventy","eighty","ninety"] decompose x  x == 0 = []  x < 20 = one !! (x1)  x >= 20 && x < 100 = ty !! (firstDigit (x)  2) ++ decompose ( x  firstDigit (x) * 10)  x < 1000 && x `mod` 100 ==0 = one !! (firstDigit (x)1) ++ "hundred"  x > 100 && x <= 999 = one !! (firstDigit (x)1) ++ "hundredand" ++decompose ( x  firstDigit (x) * 100)  x == 1000 = "onethousand" where firstDigit x = digitToInt . head . show $ x problem_17 = length . concatMap decompose $ [1..1000]
[edit] 8 Problem 18
Find the maximum sum travelling from the top of the triangle to the base.
Solution:
problem_18 = head $ foldr1 g tri where f x y z = x + max y z g xs ys = zipWith3 f xs ys $ tail ys tri = [ [75], [95,64], [17,47,82], [18,35,87,10], [20,04,82,47,65], [19,01,23,75,03,34], [88,02,77,73,07,63,67], [99,65,04,28,06,16,70,92], [41,41,26,56,83,40,80,70,33], [41,48,72,33,47,32,37,16,94,29], [53,71,44,65,25,43,91,52,97,51,14], [70,11,33,28,77,73,17,78,39,68,17,57], [91,71,52,38,17,14,91,43,58,50,27,29,48], [63,66,04,68,89,53,67,30,73,16,69,87,40,31], [04,62,98,27,23,09,70,98,73,93,38,53,60,04,23]]
[edit] 9 Problem 19
You are given the following information, but you may prefer to do some research for yourself.
 1 Jan 1900 was a Monday.
 Thirty days has September,
 April, June and November.
 All the rest have thirtyone,
 Saving February alone,
Which has twentyeight, rain or shine. And on leap years, twentynine.
 A leap year occurs on any year evenly divisible by 4, but not on a century unless it is divisible by 400.
How many Sundays fell on the first of the month during the twentieth century (1 Jan 1901 to 31 Dec 2000)?
Solution:
problem_19 = length . filter (== sunday) . drop 12 . take 1212 $ since1900 since1900 = scanl nextMonth monday . concat $ replicate 4 nonLeap ++ cycle (leap : replicate 3 nonLeap) nonLeap = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] leap = 31 : 29 : drop 2 nonLeap nextMonth x y = (x + y) `mod` 7 sunday = 0 monday = 1
Here is an alternative that is simpler, but it is cheating a bit:
import Data.Time.Calendar import Data.Time.Calendar.WeekDate problem_19_v2 = length [()  y < [1901..2000], m < [1..12], let (_, _, d) = toWeekDate $ fromGregorian y m 1, d == 7]
[edit] 10 Problem 20
Find the sum of digits in 100!
Solution:
problem_20 = sum $ map Char.digitToInt $ show $ product [1..100]