Euler problems/11 to 20

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 (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

Problem 12

What is the first triangle number to have over five-hundred divisors?

Solution:

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

Problem 13

Find the first ten digits of the sum of one-hundred 50-digit numbers.

Solution:

nums = ... -- put the numbers in a list
problem_13 = take 10 . show . sum $ nums

Problem 14

Find the longest sequence using a starting number under one million.

Solution:

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

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

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

Problem 16

What is the sum of the digits of the number 2¹⁰⁰⁰?

Solution:

problem_16 = sum.(map (read.(:[]))).show $ 2^1000

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

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 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?

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 = 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 ]