Personal tools

Euler problems/11 to 20

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=view&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:
<haskell>
+
using Array and Arrows, for fun :
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
+
</haskell>
+
 
+
Alternative, slightly easier to comprehend:
+
<haskell>
+
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
+
</haskell>
+
 
+
Second alternative, using Array and Arrows, for fun :
+
 
<haskell>
 
<haskell>
 
import Control.Arrow
 
import Control.Arrow
Line 105: Line 23:
 
           , let xs = map (a!) is
 
           , let xs = map (a!) is
 
           ]
 
           ]
 
 
main = getContents >>= print . maximum . prods . input
 
main = getContents >>= print . maximum . prods . input
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=12 Problem 12] ==
+
== [http://projecteuler.net/index.php?section=problems&id=12 Problem 12] ==
 
What is the first triangle number to have over five-hundred divisors?
 
What is the first triangle number to have over five-hundred divisors?
  
Line 123: Line 40:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=13 Problem 13] ==
+
== [http://projecteuler.net/index.php?section=problems&id=13 Problem 13] ==
 
Find the first ten digits of the sum of one-hundred 50-digit numbers.
 
Find the first ten digits of the sum of one-hundred 50-digit numbers.
  
Line 136: Line 53:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=14 Problem 14] ==
+
== [http://projecteuler.net/index.php?section=problems&id=14 Problem 14] ==
 
Find the longest sequence using a starting number under one million.
 
Find the longest sequence using a starting number under one million.
  
 
Solution:
 
Solution:
<haskell>
 
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]
 
    ]
 
</haskell>
 
 
Alternate solution, illustrating use of strict folding:
 
 
<haskell>
 
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..n-1]
 
</haskell>
 
 
 
Faster solution, using an Array to memoize length of sequences :
 
Faster solution, using an Array to memoize length of sequences :
 
<haskell>
 
<haskell>
Line 191: Line 77:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=15 Problem 15] ==
+
== [http://projecteuler.net/index.php?section=problems&id=15 Problem 15] ==
 
Starting in the top left corner in a 20 by 20 grid, how many routes are there to the bottom right corner?
 
Starting in the top left corner in a 20 by 20 grid, how many routes are there to the bottom right corner?
  
 
Solution:
 
Solution:
<haskell>
 
problem_15 =
 
    iterate (scanl1 (+)) (repeat 1) !! 20 !! 20
 
</haskell>
 
 
 
Here is a bit of explanation, and a few more solutions:
 
Here is a bit of explanation, and a few more solutions:
  
Line 207: Line 88:
  
 
<haskell>
 
<haskell>
problem_15_v2 =  
+
problem_15 =  
 
     product [21..40] `div` product [2..20]
 
     product [21..40] `div` product [2..20]
 
</haskell>
 
</haskell>
Line 219: Line 100:
  
 
<haskell>
 
<haskell>
problem_15_v3 =  
+
problem_15_v2 =  
 
     iterate (\r -> zipWith (+) (0:r) (r++[0])) [1] !! 40 !! 20
 
     iterate (\r -> zipWith (+) (0:r) (r++[0])) [1] !! 40 !! 20
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=16 Problem 16] ==
+
== [http://projecteuler.net/index.php?section=problems&id=16 Problem 16] ==
 
What is the sum of the digits of the number 2<sup>1000</sup>?
 
What is the sum of the digits of the number 2<sup>1000</sup>?
  
Line 235: Line 116:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=17 Problem 17] ==
+
== [http://projecteuler.net/index.php?section=problems&id=17 Problem 17] ==
 
How many letters would be needed to write all the numbers in words from 1 to 1000?
 
How many letters would be needed to write all the numbers in words from 1 to 1000?
  
 
Solution:
 
Solution:
<haskell>
 
-- 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
 
</haskell>
 
 
This is another solution. I think it is much cleaner than the one above.
 
 
<haskell>
 
<haskell>
 
import Char
 
import Char
Line 297: Line 146:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=18 Problem 18] ==
+
== [http://projecteuler.net/index.php?section=problems&id=18 Problem 18] ==
 
Find the maximum sum travelling from the top of the triangle to the base.
 
Find the maximum sum travelling from the top of the triangle to the base.
  
Line 325: Line 174:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=19 Problem 19] ==
+
== [http://projecteuler.net/index.php?section=problems&id=19 Problem 19] ==
 
You are given the following information, but you may prefer to do some research for yourself.
 
You are given the following information, but you may prefer to do some research for yourself.
 
* 1 Jan 1900 was a Monday.
 
* 1 Jan 1900 was a Monday.
Line 371: Line 220:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=20 Problem 20] ==
+
== [http://projecteuler.net/index.php?section=problems&id=20 Problem 20] ==
 
Find the sum of digits in 100!
 
Find the sum of digits in 100!
  
 
Solution:
 
Solution:
<haskell>
 
problem_20 =
 
    foldr ((+) . Data.Char.digitToInt) 0 $ show $ fac 100
 
    where
 
    fac n = product [1..n]
 
           
 
</haskell>
 
 
Alternate solution, summing digits directly, which is faster than the show, digitToInt route.
 
 
<haskell>
 
dsum 0 = 0
 
dsum n =
 
    m + ( dsum d )
 
    where
 
    ( d, m ) = n `divMod` 10
 
 
problem_20' =
 
    dsum . product $ [ 1 .. 100 ]
 
</haskell>
 
Alternate solution, fast Factorial, which is faster than the another two.
 
 
<haskell>
 
<haskell>
 
numPrime x p=takeWhile(>0) [div x (p^a)|a<-[1..]]
 
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=
 
fastFactorial n=
 
     product[a^x|
 
     product[a^x|
Line 418: Line 232:
 
     ]
 
     ]
 
digits n  
 
digits n  
{-  change 123 to [3,2,1]
 
-}
 
 
     |n<10=[n]
 
     |n<10=[n]
 
     |otherwise= y:digits x  
 
     |otherwise= y:digits x  
Line 425: Line 237:
 
     (x,y)=divMod n 10
 
     (x,y)=divMod n 10
 
problem_20= sum $ digits $fastFactorial 100  
 
problem_20= sum $ digits $fastFactorial 100  
 
 
</haskell>
 
</haskell>

Revision as of 14:01, 25 January 2008

Contents

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 = getContents >>= print . maximum . prods . input

2 Problem 12

What is the first triangle number to have over five-hundred 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))

3 Problem 13

Find the first ten digits of the sum of one-hundred 50-digit 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

4 Problem 14

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

Solution: 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

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: 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 = 
    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_v2 = 
    iterate (\r -> zipWith (+) (0:r) (r++[0])) [1] !! 40 !! 20

6 Problem 16

What is the sum of the digits of the number 21000?

Solution:

import Data.Char
problem_16 = sum k
    where
    s=show $2^1000
    k=map digitToInt s

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 !! (x-1)
    | 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])

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

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

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
    ]

10 Problem 20

Find the sum of digits in 100!

Solution:

numPrime x p=takeWhile(>0) [div x (p^a)|a<-[1..]]
fastFactorial n=
    product[a^x|
    a<-takeWhile(<n) primes,
    let x=sum$numPrime n a
    ]
digits n 
    |n<10=[n]
    |otherwise= y:digits x 
    where
    (x,y)=divMod n 10
problem_20= sum $ digits $fastFactorial 100