Horia Geamăn's Blog

Euler 25

horiageaman — Wed, 20 Apr 2011 20:10:16 +0000

fibs :: [Integer]
fibs = 1 : 1 : zipWith (+) fibs (tail fibs)

indexedFibs :: [(Int, Integer)]
indexedFibs = zip [1..] fibs

getFirstWithDigits :: Int -> [(Int, Integer)] -> Int
getFirstWithDigits n (p:ps) = if snd p > 10^(n-1) then fst p else getFirstWithDigits n ps

answer25 = getFirstWithDigits 1000 indexedFibs

Euler 24

horiageaman — Wed, 20 Apr 2011 20:00:30 +0000

import Data.List (sort)

-- A string used just in examples:
permutation' = "03142"

-- Create a function, nextPermutation, that generates the next lexicographic permutation.

type Index = Int

-- 0] First, a helper:
indexed :: (Ord a) => [a] -> [(a, Index)]
indexed xs = zip xs [0 .. length xs - 1]

-- 1] Looking in reverse order, find the first item that is smaller than its successor. We call it, "pivot".
--    Note: An empty list as pivot is a signal that no new permutation can be generated.
firstDefect :: (Ord a) => [(a, Index)] -> [(a, Index)]
firstDefect []          = []
firstDefect (xi:[])     = []
firstDefect (xi:yi:zis) = if fst yi < fst xi then [(fst yi, snd yi)] else firstDefect (yi:zis)

findPivot :: (Ord a) => [(a, Index)] -> [(a, Index)]
findPivot = firstDefect . reverse

-- For example:
pivot' = findPivot $ indexed permutation'

-- 2] Find the smallest value in the sublist that follows the pivot that is still greater than the pivot. We call it, "new pivot".
newPivotCandidates :: (Ord a) => [(a, Index)] -> (a, Index) -> [(a, Index)]
newPivotCandidates xis (pivot, pivotIdx) = [zi| zi <- xis, fst zi > pivot && snd zi > pivotIdx ]

findSmallestCandidate :: (Ord a) => [(a, Index)] -> [(a, Index)]
findSmallestCandidate []         = []
findSmallestCandidate (p:[])     = [p]
findSmallestCandidate (p1:p2:ps) = if (fst p1) < (fst p2) then findSmallestCandidate (p1:ps) else findSmallestCandidate (p2:ps)

-- For example
newPivot' = findSmallestCandidate $ newPivotCandidates (indexed permutation') (head pivot')

-- 3] Then, the algorithm to generate the next permutaton is this:
--  3.1] Copy everything from the original up to before the pivot;
--  3.2] Then append the new pivot;
--  3.3] Then, in the sequence that folowed the position of the pivot replace the new pivot with pivot;
--  3.4] Then reorder the sequence generated in step 3.3] ascendingly and append it to the newly rebuilt list.
--    For example, next("03142') is "03214"

replace :: (Eq a) => a -> a -> [a] -> [a]
replace a a' [] = []
replace a a' (x:xs)
    | x == a    = a' : (replace a a' xs)
	| otherwise = x  : (replace a a' xs)

nextPermutation :: (Ord a) => [a] -> [a]
nextPermutation permutation =
    let pivot = findPivot $ indexed permutation
        pivotValue = fst (head pivot)
        pivotIndex = snd (head pivot)
        newPivot = findSmallestCandidate $ newPivotCandidates (indexed permutation) (head pivot)
        newPivotValue = fst (head newPivot)
        newPivotIndex = snd (head newPivot)
        step3_1 = take pivotIndex permutation
        step3_2 = [newPivotValue]
        step3_3 = sort (replace newPivotValue pivotValue (drop (pivotIndex + 1) permutation))
    in step3_1 ++ step3_2 ++ step3_3

-- Then solve the problem:
permute :: (Ord a) => [a] -> Integer -> [a]
permute !xs n
    | n == 0    = xs
    | otherwise = permute (nextPermutation xs) (n-1)
-- (to use the bang, :set -XBangPatterns in GHC)

answer24 = permute "01234567890" 999999

Problem 23

horiageaman — Tue, 04 Jan 2011 20:36:58 +0000

This is pretty slow (15 min.). The main hog is the function madeOfAbundants; when I have time, I need to look for a faster algorithm.

halfDivisors :: Integer -> [Integer]
halfDivisors n = [ d | d <- [2..squareRoot], n `mod` d == 0 ] where squareRoot = floor $ sqrt $ fromIntegral n

properDivisors :: Integer -> [Integer]
properDivisors n = [1] ++ halfDivs ++ [d'| d <- halfDivs, let d' = n `div` d, d' > d] where halfDivs = halfDivisors n

isAbundant :: Integer -> Bool
isAbundant n = (sum $ properDivisors n) > n

abundantsUpTo :: Integer -> [Integer]
abundantsUpTo n = filter isAbundant [1..n]

abundants :: [Integer]
abundants = abundantsUpTo 28123

madeOfAbundants :: Integer -> Bool
madeOfAbundants n = not $ null [a1 | a1 <- filter (<= (n `div` 2)) abundants, elem (n - a1) abundants]

answer23 = sum [n | n <- [1..28123], not (madeOfAbundants n)]

Problem 22

horiageaman — Mon, 10 May 2010 18:04:25 +0000

import System.IO
import List
import Char

{-
This function transforms a string of the form ""MARY","PATRICIA","LINDA","BARBARA"" (which is
what we get after reading the names file) into the string "MARY PATRICIA LINDA BARBARA";
that is, it removes the inner double quotes and replaces the commas with spaces, thus preparing
the string to be split into words using the 'words' library function.
-}
toWords :: String -> String
toWords []      = []
toWords (c:cs)
    | c == '\"' =       toWords cs
    | c == ','  = ' ' : toWords cs
    | otherwise = c   : toWords cs

--Gets the individual names from the contents of the file and sorts them alphabetically:
getNames :: String -> [String]
getNames = sort . words . toWords

--Pairs each name with its index:
indexedNames :: [String] -> [(Integer, String)]
indexedNames ns = zip [1 .. toInteger $ length ns] ns

--Calculates the score of a name, irrespective of its index:
nameScore :: String -> Integer
nameScore [] = 0
nameScore (c:cs) = toInteger ((ord c) - (ord 'A') + 1) + nameScore cs

--Calculates the score of a name, taking its index into consideration:
indexedScore :: (Integer, String) -> Integer
indexedScore (i, s) = i * nameScore s

--Calculates the sum of all scores:
solve22 :: String -> Integer
solve22 contents = sum [indexedScore n | n <- indexedNames $ getNames contents]

main = do
    withFile "names.txt" ReadMode (\handle -> do
        contents <- hGetContents handle
        let answer22 = solve22 contents
        putStr $ show answer22)

Problem 21

horiageaman — Wed, 10 Mar 2010 13:58:33 +0000

properDivisors :: Int -> [Int]
properDivisors n = [ x | x <- [1..n `div` 2], n `mod` x == 0]

properSum :: Int -> Int
properSum  = sum . properDivisors

isAmicable :: Int -> Bool
isAmicable n = n == properSum n' && n /= n' where n' = properSum n

amicables :: [Int]
amicables = filter isAmicable [1..10000]

answer21 = sum amicables

Problem 20

horiageaman — Wed, 10 Mar 2010 13:55:13 +0000

answer20 = sum [read [c] | c <- show $ product [1..100]]

Problem 19

horiageaman — Tue, 09 Mar 2010 18:55:12 +0000

A little too slow (just over 100s), but an opportunity to write a few useful helper functions.

type Date = (Int, Int, Int)

-- Gets the next day relative to the given date:
nextDay :: Date -> Date
nextDay (y, m, d)
    | d == 28 && m == 2 && (y `mod` 4 /= 0 || y == 1900) = (y, 3, 1)
    | d == 29 && m == 2                                  = (y, 3, 1)
    | d == 30 && elem m [4, 6, 9, 11]                    = (y, m+1, 1)
    | d == 31                                            = if m == 12 then (y+1, 1, 1) else (y, m+1, 1)
    | otherwise                                          = (y, m, d+1) 

-- All the dates since 1900-01-01:
sinceJan1st1900 :: [Date]
sinceJan1st1900 = (1900, 1, 1) : map (nextDay) sinceJan1st1900

-- Is the first date before the second date?
before :: Date -> Date -> Bool
before (y1, m1, d1) (y2, m2, d2)
    | y1 > y2                          = False
    | y1 == y2 && m1 > m2              = False
    | y1 == y2 && m1 == m2 && d1 >= d2 = False
    | otherwise                        = True	

-- All the dates between 1900-01-01 and 2000-12-31:
xxCentury :: [Date]
xxCentury = takeWhile (`before` (2001, 1, 1)) sinceJan1st1900

-- Gets the day before the given date:
prevDay :: Date -> Date
prevDay (y, m, d)
    | d > 1     = (y, m, d-1)
    | otherwise =
        if m == 1
            then (y-1, 12, 31)
            else
                case m of
                    2 -> (y, 1, 31)
                    3 -> if (y `mod` 4 == 0) && (y /= 1900) then (y, 2, 29) else (y, 2, 28)
                    4 -> (y, 3, 31)
                    5 -> (y, 4, 30)
                    6 -> (y, 5, 31)
                    7 -> (y, 6, 30)
                    8 -> (y, 7, 31)
                    9 -> (y, 8, 31)
                    10 -> (y, 9, 30)
                    11 -> (y, 10, 31)
                    12 -> (y, 11, 30)

-- Day index relative to Jan 1st, 1900:
dayIndex :: Date -> Int
dayIndex (1900, 1, 1) = 0
dayIndex d            = 1 + dayIndex (prevDay d)

-- Get all the dates like YYYY-MM-01 between 1901-01-01 and 2000-12-31 together with their respective indices :
firstsOfMonth :: [(Date, Int)]
firstsOfMonth = [((y, m, d), dayIndex (y, m, d)) | (y, m, d) = 1901]

-- Since 1900-01-01 was a Monday and its index is 0, the Sundays are all firstsOfMonths whose indices are 7×k + 6:
sundays :: [Date]
sundays = [d | (d, i) <- firstsOfMonth, i `mod` 7 == 6]

answer19 = length sundays

Problem 18

horiageaman — Tue, 09 Mar 2010 02:59:25 +0000

So, there is a mysterious route through the triangle that gives the maximum sum. We are not required to find that route and we don’t care about it, but we know that once we are in a node on the last but one layer, we will go to the more valuable of its two descendants. That means that we can collapse any node of the last but one layer with the sum of its own value and the value of its most valuable descendant.

Therefore, an algorithm to solve the problem could be:

Replace the value in each of the nodes in the last but one row with the sum of the value in the node and the value in its most valuable descendant. Then get rid of the last row. Repeat until the tree is reduced to the root node. The value of the root is the answer.

For example, we replace the value in the first node of the last but one row (that is, 63) with the maximum between 63+4 and 63+62. Then, the 2nd node of the last but one row (66) is replaced with max (66+62, 66+98) and so on. At the end of the first iteration we get rid of the original last row, and the new last row has the nodes [125, 164, 102, ..., 54].

Note: Since we start the processing with the last row, in the actual implementation we first reverse the triangle so we work on the widest row and then call the algorithm recursively for the remaining rows below until we get to the root.

triangle :: [[Int]]
triangle = [
            [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]
           ]

reversed :: [[Int]]
reversed = reverse triangle

transform :: [[Int]] -> [[Int]]
transform [r] = [r]
transform (zs:ys:xss) = transform ([max ((ys!!i) + (zs!!i)) ((ys!!i) + (zs!!(i+1))) | i <- [0..(length zs - 2)]] : xss)

answer18 = head (head (transform reversed))

Problem 17

horiageaman — Mon, 08 Mar 2010 21:05:22 +0000

While at this, why just determine the number of characters and not write a function that generates the numeral for any number between 1 to 1000? The function numeral does exactly that:

unitName :: String -> String
unitName s =
    case read s of
        1 -> "one"
        2 -> "two"
        3 -> "three"
        4 -> "four"
        5 -> "five"
        6 -> "six"
        7 -> "seven"
        8 -> "eight"
        9 -> "nine"
        _ -> ""

teenName :: String -> String
teenName s =
    case read s of
        11 -> "eleven"
        12 -> "twelve"
        13 -> "thirteen"
        14 -> "fourteen"
        15 -> "fifteen"
        16 -> "sixteen"
        17 -> "seventeen"
        18 -> "eighteen"
        19 -> "nineteen"
        _  -> "ten"

tenName :: String -> String
tenName s =
    case s of
        "2" -> "twenty"
        "3" -> "thirty"
        "4" -> "forty"
        "5" -> "fifty"
        "6" -> "sixty"
        "7" -> "seventy"
        "8" -> "eighty"
        "9" -> "ninety"
        _   -> ""

numeral :: Int -> String
numeral n =
    case length s of
        1 -> unitName s
        2 -> if head s == '1' then teenName s else (tenName ((head s):[])) ++ (numeral (read (tail s)))
        3 -> (unitName ((head s):[])) ++ " hundred" ++ (if read (tail s) == 0 then "" else " and " ++ (numeral (read (tail s))))
        _ -> "one thousand"
    where s = show n		

numerals :: Int -> [String]
numerals x = [numeral n | n <- [1..x]]

allLetters :: String
allLetters = concat (numerals 1000)

answer17 = length [c | c <- allLetters, 'a' <= c && c <= 'z' ]

Problem 16

horiageaman — Sat, 06 Mar 2010 15:23:56 +0000

answer16 = sum [read (c:[]) | c <- show (2^1000)]