ProJeX Haskell

Posted on Thu, 5 Sep 2013

Tags: coding, mathematics, haskell, project-euler

Most of the programming languages I have learned and used so far have been from the imperative programming paradigm, which means that they describe the problem to be solved in terms what needs to be done, step by step, in order to solve it. (Object oriented programming, while often considered a separate paradigm, is essentially just a highly modular type of imperative programming.)

The alternative to the imperative paradigm is declerative programming, which describes the problem in terms of what it should accomplish, rather than how it should get there. The declerative paradigm includes logic programming languages (such as Prolog), and functional programming languages (such as Lisp or Haskell).

Functional languages are the one major paradigm which I haven't had any exposure to. Until now. I've decided that, in order to be a well-rounded coder, and also because it might be fun, I should learn a functional language; and I've chosen Haskell.

After reading the first few chapters of the strangely titled "Learn You a Haskell for Great Good!" I began thinking about what problems I can try to solve using my new language, in order to help cement my understanding. That's when I remembered about Project Euler - a series of mathematical problems intended to be solved with computer programs. I've been meaning to do Project Euler for a while now, but kept putting it off; but since Haskell is a language well suited to solving mathematical problems, I thought this was a perfect opportunity to combine the two, in ProJeX Haskell: learning Haskell through using it to solve Project Euler problems (and presenting the mathematics using LaTeX - another thing I've been meaning to learn).

Ok, so lets delve straight in…

Some general functions

Here are some general functions, that will be made use of in the following sections.

-- factorial
factorial 0 = 1
factorial n = n * factorial (n-1)
-- fibonacci sequence
fibonacci = 0 : 1 : zipWith (+) fib (tail fib)
-- combinations
choose n 0 = 1
choose 0 k = 0
choose n k = choose (n-1) (k-1) * n `div` k
-- permutations
permute n 0 = 1
permute 0 k = 0
permute n k = permute (n-1) (k-1) * n
-- sum of the digits of a number
digitSum 0 = 0
digitSum x = let (d, m) = x `divMod` 10 in m + digitSum d

I originally wrote the fibonacci function in a step-wise manner (similar to the factorial function), but the version given here is faster (and nicer to look at).

A few trivial problems

It quickly becomes clear how well-suited Haskell is to solving mathematical problems. The solutions to many of these early problems can be written in a line or two!

import qualified Data.List (sort, nub)
import qualified Data.Char (toUpper, ord)
-- 1: Sum of all multiples of 3 and 5 below 1000
euler1 = sum [x | x <- [1..999], x `mod` 3 == 0 || x `mod` 5 == 0]
-- 2: Sum of all even Fibonacci numbers under 4 million
euler2 = sum [x | x <- (takeWhile (<= 4000000) fibonacci), even x]
-- 4: Largest palindromic product of two 3-digit numbers
euler4 = maximum [z | x <- [100..999], y <- [1..x], let z = x*y, (show z) == (reverse . show $ z)]
-- 6: Sum square difference (square of sum - sum of squares) of 1..100
euler6 = ((^2) . sum $ xs) - (sum . map (^2) $ xs)
where xs = [1..100]
-- 8: Largest product of 5 digits in a series
euler8 = maxProd5InSeries [7,3,1,6,7,1, {- ... the rest of the digits -}]
maxProd5InSeries xs
| (length xs < 5) = 0
| otherwise = max (product . take 5 $ xs) (maxProd5InSeries . tail $ xs)
-- 9: Pythagorean triplet for which a+b+c = 1000
euler9 = head [(a*b*c) * (1000 `div` (a+b+c))^3 | c <- [1..], b <- [1..c], a <- [1..b],
a^2 + b^2 == c^2, 1000 `mod` (a+b+c) == 0]
-- 15: Lattice paths - number of routes through a grid
euler15 = paths 20 20
where paths rows cols = (rows + cols) `choose` rows
-- 16: Power digit sum (sum of the digits of 2^1000)
euler16 = digitSum (2^1000)
-- 20: Factorial digit sum (sum of the digits of 100!)
euler20 = digitSum . factorial $ 100
-- 22: Name Scores
euler22 = sum . zipWith (*) [1..] .
map (foldl (\ acc x -> acc + alphaValue x) 0) . Data.List.sort $ names
where alphaValue = subtract 64 . Data.Char.ord . Data.Char.toUpper
names = [{- name list -}]
-- 25: 1000-digit Fibonacci number
euler25 = length . takeWhile (< 10^999) $ fibonacci
-- 29: Distinct powers of a^b such that a,b ∈ [2..100]
euler29 = length . Data.List.nub $ [a^b | a <- [2..100], b <- [2..100]]
-- 31: Coin sums (number of ways of making £2)
euler31 = length . coinCombos 200 $ [200, 100, 50, 20, 10, 5, 2, 1]
coinCombos total coins
| null remCoins = [[]]
| otherwise = concat [map (x:) . coinCombos (total - x) . dropWhile (> x) $
remCoins | x <- remCoins]
where remCoins = dropWhile (> total) coins

Many of these solutions are self-explanatory. I'll just make a few notes:

Problem 11

What is the greatest product of four adjacent numbers in the same direction in a 20×20 grid?

First, I represent the grid as a list of lists. I then call a recursive function on the grid. The function takes a cell as its input, and calculates a "product of four" for each direction from that cell: up-right, right, down-right, down. The recursive call does the same thing from each starting cell. The function then finds the maximum product.

-- 11: Largest product of 4 in a 20*20 grid
euler11 = maxProd4InGrid
[
[08, 02, 22, 97, 38, 15, 00, 40, 00, 75, 04, 05, 07, 78, 52, 12, 50, 77, 91, 08],
[49, 49, 99, 40, 17, 81, 18, 57, 60, 87, 17, 40, 98, 43, 69, 48, 04, 56, 62, 00],
[81, 49, 31, 73, 55, 79, 14, 29, 93, 71, 40, 67, 53, 88, 30, 03, 49, 13, 36, 65],
[52, 70, 95, 23, 04, 60, 11, 42, 69, 24, 68, 56, 01, 32, 56, 71, 37, 02, 36, 91],
[22, 31, 16, 71, 51, 67, 63, 89, 41, 92, 36, 54, 22, 40, 40, 28, 66, 33, 13, 80],
[24, 47, 32, 60, 99, 03, 45, 02, 44, 75, 33, 53, 78, 36, 84, 20, 35, 17, 12, 50],
[32, 98, 81, 28, 64, 23, 67, 10, 26, 38, 40, 67, 59, 54, 70, 66, 18, 38, 64, 70],
[67, 26, 20, 68, 02, 62, 12, 20, 95, 63, 94, 39, 63, 08, 40, 91, 66, 49, 94, 21],
[24, 55, 58, 05, 66, 73, 99, 26, 97, 17, 78, 78, 96, 83, 14, 88, 34, 89, 63, 72],
[21, 36, 23, 09, 75, 00, 76, 44, 20, 45, 35, 14, 00, 61, 33, 97, 34, 31, 33, 95],
[78, 17, 53, 28, 22, 75, 31, 67, 15, 94, 03, 80, 04, 62, 16, 14, 09, 53, 56, 92],
[16, 39, 05, 42, 96, 35, 31, 47, 55, 58, 88, 24, 00, 17, 54, 24, 36, 29, 85, 57],
[86, 56, 00, 48, 35, 71, 89, 07, 05, 44, 44, 37, 44, 60, 21, 58, 51, 54, 17, 58],
[19, 80, 81, 68, 05, 94, 47, 69, 28, 73, 92, 13, 86, 52, 17, 77, 04, 89, 55, 40],
[04, 52, 08, 83, 97, 35, 99, 16, 07, 97, 57, 32, 16, 26, 26, 79, 33, 27, 98, 66],
[88, 36, 68, 87, 57, 62, 20, 72, 03, 46, 33, 67, 46, 55, 12, 32, 63, 93, 53, 69],
[04, 42, 16, 73, 38, 25, 39, 11, 24, 94, 72, 18, 08, 46, 29, 32, 40, 62, 76, 36],
[20, 69, 36, 41, 72, 30, 23, 88, 34, 62, 99, 69, 82, 67, 59, 85, 74, 04, 36, 16],
[20, 73, 35, 29, 78, 31, 90, 01, 74, 31, 49, 71, 48, 86, 81, 16, 23, 57, 05, 54],
[01, 70, 54, 71, 83, 51, 54, 69, 16, 92, 33, 48, 61, 43, 52, 01, 89, 19, 67, 48]
] 0 0
maxProd4InGrid g r c
| c > cMax = maxProd4InGrid g (r+1) (c-cMax-1)
| r > rMax = 0
| otherwise = maximum [
if (r `elem` [3..rMax] && c `elem` [0..(cMax-3)]) -- up right
then product [g!!r!!c, g!!(r-1)!!(c+1), g!!(r-2)!!(c+2), g!!(r-3)!!(c+3)] else 0,
if (r `elem` [0..rMax] && c `elem` [0..(cMax-3)]) -- right
then product [g!!r!!c, g!!r!!(c+1), g!!r!!(c+2), g!!r!!(c+3)] else 0,
if (r `elem` [0..(rMax-3)] && c `elem` [0..(cMax-3)]) -- down right
then product [g!!r!!c, g!!(r+1)!!(c+1), g!!(r+2)!!(c+2), g!!(r+3)!!(c+3)] else 0,
if (r `elem` [0..(rMax-3)] && c `elem` [0..cMax]) -- down
then product [g!!r!!c, g!!(r+1)!!c, g!!(r+2)!!c, g!!(r+3)!!c] else 0,
maxProd4InGrid g r (c+1) -- the rest
]
where rMax = (length g) - 1
cMax = length (g !! 0) - 1

Problem 14

A Collatz sequence is defined as follows: $$ \begin{alignat*}{3} n &\rightarrow {n/2} &\;&\text{(for even n)} \\ n &\rightarrow {3n + 1} &\;&\text{(for odd n)} \end{alignat*} $$ Which starting number, under one million, produces the longest chain?

First, we need to write a function to generate a Collatz sequence from a starting number. This is easy enough to do using the provided recursive definition.

I've taken a brute force approach: take all numbers under one million, generate the corresponding sequences, and keep the longest one.

I have made a small optimisation: I've started at 5000, since for any number in the lower half, there is an even number in the upper half which leads to it.

-- 14: Longest Collatz sequence (starting below 1 million)
euler14 = foldl1 (\ x y -> if snd x > snd y then x else y)
[(x, length . collatz $ x) | x <- [500000..999999]]
collatz 1 = [1]
collatz n
| even n = n : collatz (n `div` 2)
| otherwise = n : collatz (3*n + 1)

This approach takes around a minute to find the answer. There may be a quicker way to do this, perhaps one that doesn't involve generating every sequence, but this method is sufficient.

Problem 17

If all the numbers from 1 to 1000 were written out in words, how many letters would be used?

For this problem, I took a slightly more general approach than necessary. I wrote a numberWords function to write out in words any number under one million, including spaces and punctuation. I then used this function to write all numbers in the required range, removed the undesirable characters, and counted the length of the final string.

The numberWords function works recursively, getting the thousands part of the number (if appropriate), then the hundreds, tens and units, respectively.

-- 17: Number letter counts (number of letters used to write 1 - 1000 in words)
euler17 = length . filter (flip notElem " ,-") . foldl1 (++) $ [numberWords x | x <- [1..1000]]
numberWords n
| (n < 20) = units !! n
| (n < 100) = let (d, m) = n `divMod` 10 in tens !! d ++
(if m > 0 then "-" ++ numberWords m else "")
| (n < 1000) = let (d, m) = n `divMod` 100 in units !! d ++ " hundred" ++
(if m > 0 then " and " ++ numberWords m else "")
| (n < 1000000) = let (d, m) = n `divMod` 1000 in numberWords d ++ " thousand," ++
(if m > 0 then " " else "") ++
(if m `elem` [1..99] then "and " else "") ++ numberWords m
where units = ["","one","two","three","four","five","six","seven","eight","nine","ten",
"eleven","twelve","thirteen","fourteen","fifteen",
"sixteen","seventeen","eighteen","nineteen"]
tens = ["","","twenty","thirty","forty","fifty","sixty","seventy","eighty","ninety"]

Here is some example output from the numberWords function:

> numberWords 128
"one hundred and twenty-eight"
> numberWords 57206
"fifty-seven thousand, two hundred and six"
> numberWords 700113
"seven hundred thousand, one hundred and thirteen"

Problem 19

How many Sundays fell on the first of the month during the twentieth century?

Once again, a more general solution than strictly necessary. The function dayOfTheWeek will give the day for any date in history (or, any date since Gregorian calendar was introduced). This function is then used to check by brute force which "first of the month"s fell on a Sunday.

-- 19: Counting Sundays (Number of Sundays on the first of the month during the twentieth century)
euler19 = length [1 | y <- [1901..2000], m <- [1..12], (dayOfTheWeek y m 1) == "Sunday"]
dayOfTheWeek year month day = days !! (daysSince1900 `mod` 7)
where days = ["Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"]
daysSince1900
| (year - 1900) >= 0 = sum $ day : [daysInTheMonth year m | m <- [1..(month-1)]] ++
[daysInTheMonth y m | y <- [1900..(year-1)], m <- [1..12]]
| otherwise = negate . sum $ ((daysInTheMonth year month) - day) :
[daysInTheMonth year m | m <- [(month+1)..12]] ++
[daysInTheMonth y m | y <- [(year+1)..1899], m <- [1..12]]
daysInTheMonth y m
| m == 2 = if leapYear then 29 else 28
| m `elem` [9, 4, 6, 11] = 30
| otherwise = 31
where leapYear = (y `mod` 4 == 0) && ((y `mod` 100 > 0) || (y `mod` 400 == 0))

According to the dayOfTheWeek function, 20th May 1950 was a Saturday, and 31st December 1812 was a Thursday! Good to know.

Problem 28

What is the sum of the diagonals in a 1001 by 1001 Ulam spiral?

For this one, I spent a little bit of time figuring out the pattern. Let the nth spiral be the one with edge n:

The diagonals of the odd spirals begin at 1, then proceed in fours:
| 1 | 3 5 7 9 | 13 17 21 25 | 31 37 43 49 | 57 65 73 81 | ...
So, for example, the diagonals added for the 5th spiral, \(D_5 = [13, 17, 21, 25]\).

The diagonals of the even spirals proceed in groups of four as follows:
| (0) | 1 2 3 4 | 7 10 13 16 | 21 26 31 36 | 43 50 57 64 | ...
I have included the case \(D_0 = [0]\), as it makes things simpler (and doesn't affect the sum we're after).

Now, it should be clear that the diagonals added for the nth spiral are an arithmetic progression continuing on from the previous number in the odd/even sequence, with a common difference of \(n-1\).
That is, if \(D_{n-2} = [i, j, k, l]\), then \(D_{n} = [l+(n-1), l+2(n-1), l+3(n-1), l+4(n-1)]\).
For example, \(D_{7} = [25+(7-1), 25+2(7-1), 25+3(7-1), 25+4(7-1)] = [31, 37, 43, 49]\).

That's all we need to know to generate all the diagonals for our 1001 by 1001 spiral, and then sum them to get our answer.

-- 28: Number spiral diagonals (sum of the diagonals in a 1001 by 1001 ulam spiral)
euler28 = sum . spiralDiags $ 1001
spiralDiags 0 = [0]
spiralDiags 1 = [1]
spiralDiags n = map ((+ head prev) . (*(n-1))) [4,3,2,1] ++ prev
where prev = spiralDiags (n-2)

That's all for now. There will be more ProJeX Haskell posts to come in the future.

Categories