Difference between revisions of "Euler problems/11 to 20"

From HaskellWiki
Jump to: navigation, search
(Problem 14: streamline code)
 
(17 intermediate revisions by 10 users not shown)
Line 16: Line 16:
   
 
prods :: Array (Int, Int) Int -> [Int]
 
prods :: Array (Int, Int) Int -> [Int]
prods a = [product xs |
+
prods a = [product xs | i <- range $ bounds a,
i <- range $ bounds a
+
s <- senses,
, s <- senses
+
let is = take 4 $ iterate s i,
, let is = take 4 $ iterate s i
+
all (inArray a) is,
, all (inArray a) is
+
let xs = map (a!) is]
, let xs = map (a!) is
+
main = print . maximum . prods . input =<< getContents
]
 
main = getContents >>= print . maximum . prods . input
 
 
</haskell>
 
</haskell>
   
Line 30: Line 30:
 
<haskell>
 
<haskell>
 
--primeFactors in problem_3
 
--primeFactors in problem_3
problem_12 =
 
  +
problem_12 = head $ filter ((> 500) . nDivisors) triangleNumbers
head $ filter ((> 500) . nDivisors) triangleNumbers
 
  +
where nDivisors n = product $ map ((+1) . length) (group (primeFactors n))
where
 
  +
triangleNumbers = scanl1 (+) [1..]
triangleNumbers = scanl1 (+) [1..]
 
nDivisors n =
 
product $ map ((+1) . length) (group (primeFactors n))
 
 
</haskell>
 
</haskell>
   
Line 43: Line 40:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
sToInt =(+0).read
 
  +
main=do
 
  +
main = do xs <- fmap (map read . lines) (readFile "p13.log")
a<-readFile "p13.log"
 
  +
print . take 10 . show . sum $ xs
let b=map sToInt $lines a
 
let c=take 10 $ show $ sum b
 
print c
 
 
</haskell>
 
</haskell>
   
Line 55: Line 49:
   
 
Solution:
 
Solution:
Faster solution, using an Array to memoize length of sequences :
 
  +
<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..n-1]
  +
</haskell>
  +
  +
Faster solution, using unboxed types and parallel computation:
  +
<haskell>
  +
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)
  +
</haskell>
  +
  +
Even faster solution, using an Array to memoize length of sequences :
 
<haskell>
 
<haskell>
 
import Data.Array
 
import Data.Array
 
import Data.List
 
import Data.List
  +
import Data.Ord (comparing)
   
 
syrs n =
 
syrs n =
 
a
 
a
 
where
 
where
a = listArray (1,n) $ 0:[1 + syr n x | x <- [2..n]]
+
a = listArray (1,n) $ 0 : map syr [2..n]
syr n x =
+
syr x =
if x' <= n then a ! x' else 1 + syr n x'
+
if y <= n then 1 + a ! y else 1 + syr y
 
where
 
where
x' = if even x then x `div` 2 else 3 * x + 1
+
y = if even x then x `div` 2 else 3 * x + 1
   
 
main =
 
main =
print $ foldl' maxBySnd (0,0) $ assocs $ syrs 1000000
+
print . maximumBy (comparing snd) . assocs . syrs $ 1000000
where
 
maxBySnd x@(_,a) y@(_,b) = if a > b then x else y
 
 
</haskell>
 
</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
  +
  +
  +
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 (=sequence-length) is greater
  +
| a > b = (a,c)
  +
| otherwise = (b,d)
  +
  +
main = print answer
  +
</haskell>
  +
-->
   
 
== [http://projecteuler.net/index.php?section=problems&id=15 Problem 15] ==
 
== [http://projecteuler.net/index.php?section=problems&id=15 Problem 15] ==
Line 77: Line 132:
   
 
Solution:
 
Solution:
Here is a bit of explanation, and a few more solutions:
 
  +
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
 
Each route has exactly 40 steps, with 20 of them horizontal and 20 of
Line 84: Line 144:
   
 
<haskell>
 
<haskell>
problem_15 =
+
problem_15 = product [21..40] `div` product [2..20]
product [21..40] `div` product [2..20]
 
</haskell>
 
 
The first solution calculates this using the clever trick of contructing
 
[http://en.wikipedia.org/wiki/Pascal's_triangle Pascal's triangle]
 
along its diagonals.
 
 
Here is another solution that constructs Pascal's triangle in the usual way,
 
row by row:
 
 
<haskell>
 
problem_15_v2 =
 
iterate (\r -> zipWith (+) (0:r) (r++[0])) [1] !! 40 !! 20
 
 
</haskell>
 
</haskell>
   
Line 94: Line 154:
 
import Data.Char
 
import Data.Char
 
problem_16 = sum k
 
problem_16 = sum k
where
 
  +
where s = show (2^1000)
s=show $2^1000
 
  +
k = map digitToInt s
k=map digitToInt s
 
 
</haskell>
 
</haskell>
   
Line 122: Line 181:
 
| x == 1000 = "onethousand"
 
| x == 1000 = "onethousand"
   
where
 
  +
where firstDigit x = digitToInt . head . show $ x
firstDigit x = digitToInt$head (show x)
 
   
problem_17 =
 
  +
problem_17 = length . concatMap decompose $ [1..1000]
length$concat (map decompose [1..1000])
 
 
</haskell>
 
</haskell>
   
Line 134: Line 191:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_18 =
+
problem_18 = head $ foldr1 g tri
head $ foldr1 g tri
+
where
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 172: Line 229:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_19 =
 
  +
problem_19 = length . filter (== sunday) . drop 12 . take 1212 $ since1900
length $ filter (== sunday) $ drop 12 $ take 1212 since1900
 
  +
since1900 = scanl nextMonth monday . concat $
since1900 =
 
  +
replicate 4 nonLeap ++ cycle (leap : replicate 3 nonLeap)
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]
nonLeap =
 
  +
[31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]
 
  +
leap = 31 : 29 : drop 2 nonLeap
leap =
 
  +
31 : 29 : drop 2 nonLeap
 
  +
nextMonth x y = (x + y) `mod` 7
nextMonth x y =
 
  +
(x + y) `mod` 7
 
 
sunday = 0
 
sunday = 0
 
monday = 1
 
monday = 1
Line 193: Line 249:
 
import Data.Time.Calendar.WeekDate
 
import Data.Time.Calendar.WeekDate
   
problem_19_v2 =
+
problem_19_v2 = length [() | y <- [1901..2000],
length [() |
+
m <- [1..12],
y <- [1901..2000],
+
let (_, _, d) = toWeekDate $ fromGregorian y m 1,
m <- [1..12],
+
d == 7]
let (_, _, d) = toWeekDate $ fromGregorian y m 1,
 
d == 7
 
]
 
 
</haskell>
 
</haskell>
   
Line 204: Line 260:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
numPrime x p=takeWhile(>0) [div x (p^a)|a<-[1..]]
 
  +
problem_20 = sum $ map Char.digitToInt $ show $ product [1..100]
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
 
 
</haskell>
 
</haskell>

Latest revision as of 15:16, 16 September 2015

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

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 nDivisors n = product $ map ((+1) . length) (group (primeFactors n))    
        triangleNumbers = scanl1 (+) [1..]

Problem 13

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

Solution:

main = do xs <- fmap (map read . lines) (readFile "p13.log")
          print . take 10 . show . sum $ xs

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..n-1]

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 : map syr [2..n]
    syr x = 
        if y <= n then 1 + a ! y else 1 + syr y
        where 
        y = if even x then x `div` 2 else 3 * x + 1

main = 
    print . maximumBy (comparing snd) . assocs . syrs $ 1000000


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]

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

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

Problem 20

Find the sum of digits in 100!

Solution:

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