Euler problems/11 to 20
What is the greatest product of four numbers on the same straight line in the 20 by 20 grid?
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 (transpose) import Data.List (tails, inits, maximumBy) num = undefined --list of lists of numbers, one list per row rows = num cols = transpose rows diag b = [b !! n !! n | n <- [0 .. length b - 1], n < (length (transpose b))] 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) getAllDiags f g = map f [drop n . take (length g) $ g | n <- [1.. (length g - 1)]] allposs = rows ++ cols ++ diagLs ++ diagRs allfours = [x | xss <- allposs, xs <- inits xss, x <- tails xs, length x == 4] answer = maximumBy (\(x, _) (y, _) -> compare x y) (zip (map product allfours) allfours)
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
What is the first triangle number to have over five-hundred divisors?
problem_12 = head $ filter ((> 500) . nDivisors) triangleNumbers where triangleNumbers = scanl1 (+) [1..] nDivisors n = product $ map ((+1) . length) (group (primeFactors n)) 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
Find the first ten digits of the sum of one-hundred 50-digit numbers.
nums = ... -- put the numbers in a list problem_13 = take 10 . show . sum $ nums
Find the longest sequence using a starting number under one million.
p14s :: Integer -> [Integer] p14s n = n : p14s' n where p14s' n = if n' == 1 then  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 :: 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..n-1]
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
Starting in the top left corner in a 20 by 20 grid, how many routes are there to the bottom right corner?
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++))  !! 40 !! 20
What is the sum of the digits of the number 21000?
problem_16 = sum.(map (read.(:))).show $ 2^1000
How many letters would be needed to write all the numbers in words from 1 to 1000?
-- 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
Find the maximum sum travelling from the top of the triangle to the base.
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 = [ , [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]]
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 thirty-one,
- Saving February alone,
Which has twenty-eight, rain or shine. And on leap years, twenty-nine.
- 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)?
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]
Find the sum of digits in 100!
problem_20 = let fac n = product [1..n] in foldr ((+) . Data.Char.digitToInt) 0 $ show $ fac 100
Alternate solution, summing digits directly, which is faster than the show, digitToInt route.
dsum 0 = 0 dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d ) problem_20' = dsum . product $ [ 1 .. 100 ]