Difference between revisions of "Euler problems/11 to 20"
Line 49:  Line 49:  
diag b = [b !! n !! n  
diag b = [b !! n !! n  

n < [0 .. length b  1], 
n < [0 .. length b  1], 

−  n 
+  (>n)$length $transpose b 
] 
] 

getAllDiags f g = map f 
getAllDiags f g = map f 

Line 55:  Line 55:  
n < [1.. (length g  1)] 
n < [1.. (length g  1)] 

] 
] 

−  problem_11 num= 
+  problem_11 num= 
+  maximumBy (\(x, _) (y, _) > compare x y) 

$zip (map product allfours) allfours 
$zip (map product allfours) allfours 

where 
where 

Line 77:  Line 77:  
length x == 4 
length x == 4 

] 
] 

−  
+  sToInt x=map ((+0).read) $words x 

−  split :: Char > String > [String] 

−  split = unfoldr . split' 

−  
−  split' :: Char > String > Maybe (String, String) 

−  split' c l 

−   null l = Nothing 

−   otherwise = Just (h, drop 1 t) 

−  where (h, t) = span (/=c) l 

−  sToInt x=map ((+0).read) $split ' ' x 

main=do 
main=do 

a<readFile "p11.log" 
a<readFile "p11.log" 

Line 122:  Line 113:  
Solution: 
Solution: 

<haskell> 
<haskell> 

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

+  primeFactors in problem_3 

−  where triangleNumbers = scanl1 (+) [1..] 

+  problem_12 = 

−  nDivisors n = product $ map ((+1) . length) (group (primeFactors n)) 

+  head $ filter ((> 500) . nDivisors) triangleNumbers 

−  primes = 2 : filter ((== 1) . length . primeFactors) [3,5..] 

+  where 

−  primeFactors n = factor n primes 

+  triangleNumbers = scanl1 (+) [1..] 

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

+  nDivisors n = 

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

+  product $ map ((+1) . length) (group (primeFactors n)) 

−   otherwise = factor n ps 

</haskell> 
</haskell> 

Line 150:  Line 140:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  p14s :: Integer > [Integer] 

+  p14s n = 

−  +  n : p14s' n 

−  +  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 

−  problem_14 = fst $ head $ sortBy (\(_,x) (_,y) > compare y x) [(x, length $ p14s x)  x < [1 .. 999999]] 

+  problem_14 = 

+  fst $ head $ 

+  sortBy (\(_,x) (_,y) > compare y x) [(x, length $ p14s x)  

+  x < [1 .. 999999] 

+  ] 

</haskell> 
</haskell> 

Line 163:  Line 157:  
import Data.List 
import Data.List 

−  problem_14 = 
+  problem_14 = 
−  +  j 1000000 

+  where 

f k 1 = k 
f k 1 = k 

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

Line 177:  Line 171:  
import Data.List 
import Data.List 

−  syrs n = 
+  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 $ foldl' maxBySnd (0,0) $ assocs $ syrs 1000000 

+  main = 

−  +  print $ foldl' maxBySnd (0,0) $ assocs $ syrs 1000000 

+  where 

+  maxBySnd x@(_,a) y@(_,b) = if a > b then x else y 

</haskell> 
</haskell> 

Line 191:  Line 185:  
Solution: 
Solution: 

<haskell> 
<haskell> 

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

+  problem_15 = 

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

</haskell> 
</haskell> 

Line 201:  Line 196:  
<haskell> 
<haskell> 

−  problem_15_v2 = 
+  problem_15_v2 = 
+  product [21..40] `div` product [2..20] 

</haskell> 
</haskell> 

Line 212:  Line 207:  
<haskell> 
<haskell> 

−  problem_15_v3 = iterate (\r > zipWith (+) (0:r) (r++[0])) [1] !! 40 !! 20 

+  problem_15_v3 = 

+  iterate (\r > zipWith (+) (0:r) (r++[0])) [1] !! 40 !! 20 

</haskell> 
</haskell> 

Line 266:  Line 262:  
import Char 
import Char 

−  one = ["one","two","three","four","five","six","seven","eight 
+  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"] 
ty = ["twenty","thirty","forty","fifty","sixty","seventy","eighty","ninety"] 

−  decompose x 
+  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 
+  where 
firstDigit x = digitToInt$head (show x) 
firstDigit x = digitToInt$head (show x) 

−  problem_17 = length$concat (map decompose [1..1000])</haskell> 

+  problem_17 = 

+  length$concat (map decompose [1..1000]) 

+  </haskell> 

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

Line 289:  Line 287:  
Solution: 
Solution: 

<haskell> 
<haskell> 

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

+  where 

f x y z = x + max y z 
f x y z = x + max y z 

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

Line 328:  Line 326:  
problem_19 = 
problem_19 = 

length $ filter (== sunday) $ drop 12 $ take 1212 since1900 
length $ filter (== sunday) $ drop 12 $ take 1212 since1900 

−  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 
sunday = 0 

monday = 1 
monday = 1 

Line 357:  Line 355:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_20 = 
+  problem_20 = 
−  +  foldr ((+) . Data.Char.digitToInt) 0 $ show $ fac 100 

+  where 

+  fac n = product [1..n] 

+  
</haskell> 
</haskell> 

Line 365:  Line 363:  
<haskell> 
<haskell> 

dsum 0 = 0 
dsum 0 = 0 

−  dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d ) 

+  dsum n = 

+  m + ( dsum d ) 

+  where 

+  ( d, m ) = n `divMod` 10 

−  problem_20' = 
+  problem_20' = 
+  dsum . product $ [ 1 .. 100 ] 

</haskell> 
</haskell> 

Alternate solution, fast Factorial, which is faster than the another two. 
Alternate solution, fast Factorial, which is faster than the another two. 
Revision as of 13:44, 16 January 2008
Contents
Problem 11
What is the greatest product of four numbers on the same straight line in the 20 by 20 grid?
Solution:
import System.Process
import IO
import List
slurpURL url = do
(_,out,_,_) < runInteractiveCommand $ "curl " ++ url
hGetContents out
parse_11 src =
let npre p = or.(zipWith (/=) p)
clip p q xs = takeWhile (npre q) $ dropWhile (npre p) xs
trim s =
let (x,y) = break (== '<') s
(_,z) = break (== '>') y
in if null z then x else x ++ trim (tail z)
in map ((map read).words.trim) $ clip "08" "</p>" $ lines src
solve_11 xss =
let mult w x y z = w*x*y*z
zipf f (w,x,y,z) = zipWith4 f w x y z
zifm = zipf mult
zifz = zipf (zipWith4 mult)
tupl = zipf (\w x y z > (w,x,y,z))
skew (w,x,y,z) = (w, drop 1 x, drop 2 y, drop 3 z)
sker (w,x,y,z) = skew (z,y,x,w)
skex x = skew (x,x,x,x)
maxl = foldr1 max
maxf f g = maxl $ map (maxl.f) $ g xss
in maxl
[ maxf (zifm.skex) id
, maxf id (zifz.skex)
, maxf (zifm.skew) (tupl.skex)
, maxf (zifm.sker) (tupl.skex) ]
problem_11 = do
src < slurpURL "http://projecteuler.net/print.php?id=11"
print $ solve_11 $ parse_11 src
Alternative, slightly easier to comprehend:
import Data.List
diag b = [b !! n !! n 
n < [0 .. length b  1],
(>n)$length $transpose b
]
getAllDiags f g = map f
[drop n . take (length g) $ g 
n < [1.. (length g  1)]
]
problem_11 num=
maximumBy (\(x, _) (y, _) > compare x y)
$zip (map product allfours) allfours
where
rows = num
cols = transpose rows
diagLs =
diag rows : diagup ++ diagdown
where
diagup = getAllDiags diag rows
diagdown = getAllDiags diag cols
diagRs =
diag (reverse rows) : diagup ++ diagdown
where
diagup = getAllDiags diag (reverse num)
diagdown = getAllDiags diag (transpose $ reverse num)
allposs = rows ++ cols ++ diagLs ++ diagRs
allfours = [x 
xss < allposs,
xs < inits xss,
x < tails xs,
length x == 4
]
sToInt x=map ((+0).read) $words x
main=do
a<readFile "p11.log"
let b=map sToInt $lines a
print $problem_11 b
Second alternative, 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 = getContents >>= print . maximum . prods . input
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
triangleNumbers = scanl1 (+) [1..]
nDivisors n =
product $ map ((+1) . length) (group (primeFactors n))
Problem 13
Find the first ten digits of the sum of onehundred 50digit numbers.
Solution:
sToInt =(+0).read
main=do
a<readFile "p13.log"
let b=map sToInt $lines a
let c=take 10 $ show $ sum b
print c
Problem 14
Find the longest sequence using a starting number under one million.
Solution:
p14s n =
n : p14s' n
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
problem_14 =
fst $ head $
sortBy (\(_,x) (_,y) > compare y x) [(x, length $ p14s x) 
x < [1 .. 999999]
]
Alternate solution, illustrating use of strict folding:
import Data.List
problem_14 =
j 1000000
where
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 an Array to memoize length of sequences :
import Data.Array
import Data.List
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 $ foldl' maxBySnd (0,0) $ assocs $ syrs 1000000
where
maxBySnd x@(_,a) y@(_,b) = if a > b then x else y
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:
problem_15 =
iterate (scanl1 (+)) (repeat 1) !! 20 !! 20
Here is a bit of explanation, and a few more solutions:
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_v2 =
product [21..40] `div` product [2..20]
The first solution calculates this using the clever trick of contructing Pascal's triangle along its diagonals.
Here is another solution that constructs Pascal's triangle in the usual way, row by row:
problem_15_v3 =
iterate (\r > zipWith (+) (0:r) (r++[0])) [1] !! 40 !! 20
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
Problem 17
How many letters would be needed to write all the numbers in words from 1 to 1000?
Solution:
 not a very concise or beautiful solution, but food for improvements :)
names = concat $
[zip [(0, n)  n < [0..19]]
["", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight"
,"Nine", "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen"
,"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
spell n = unwords $ if last s == "and" then init s else s
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
This is another solution. I think it is much cleaner than the one above.
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$concat (map decompose [1..1000])
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]]
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
]
Problem 20
Find the sum of digits in 100!
Solution:
problem_20 =
foldr ((+) . Data.Char.digitToInt) 0 $ show $ fac 100
where
fac n = product [1..n]
Alternate solution, summing digits directly, which is faster than the show, digitToInt route.
dsum 0 = 0
dsum n =
m + ( dsum d )
where
( d, m ) = n `divMod` 10
problem_20' =
dsum . product $ [ 1 .. 100 ]
Alternate solution, fast Factorial, which is faster than the another two.
numPrime x p=takeWhile(>0) [div x (p^a)a<[1..]]
merge xs@(x:xt) ys@(y:yt) = case compare x y of
LT > x : (merge xt ys)
EQ > x : (merge xt yt)
GT > y : (merge xs yt)
diff xs@(x:xt) ys@(y:yt) = case compare x y of
LT > x : (diff xt ys)
EQ > diff xt yt
GT > diff xs yt
primes = [2,3,5] ++ (diff [7,9..] nonprimes)
nonprimes = foldr1 f . map g $ tail primes
where f (x:xt) ys = x : (merge xt ys)
g p = [ n*p  n < [p,p+2..]]
fastFactorial n=
product[a^x
a<takeWhile(<n) primes,
let x=sum$numPrime n a
]
digits n
{ change 123 to [3,2,1]
}
n<10=[n]
otherwise= y:digits x
where
(x,y)=divMod n 10
problem_20= sum $ digits $fastFactorial 100