Euler problems/31 to 40

Problem 31

Investigating combinations of English currency denominations.

Solution:

This is the naive doubly recursive solution. Speed would be greatly improved by use of memoization, dynamic programming, or the closed form.

problem_31 = pence 200 [1,2,5,10,20,50,100,200]
    where pence 0 _  = 1
          pence n [] = 0
          pence n denominations@(d:ds)
                | n < d     = 0
                | otherwise = pence (n - d) denominations
                              + pence n ds

A beautiful solution, making usage of laziness and recursion to implement a dynamic programming scheme, blazingly fast despite actually generating the combinations and not only counting them :

coins = [1,2,5,10,20,50,100,200]

combinations = foldl (\without p ->
                          let (poor,rich) = splitAt p without
                              with = poor ++ 
                                     zipWith (++) (map (map (p:)) with)
                                                  rich
                          in with
                     ) ([[]] : repeat [])

problem_31 = length $ combinations coins !! 200

Problem 32

Find the sum of all numbers that can be written as pandigital products.

Solution:

problem_32 = sum $ nub $  map (\(a, b) -> a * b) multiplicands
    where
        multiplicands =
            [(a,b)| a <- [2..5000], b <- [a..(9999 `div` a)], check a b]
        check a b =
            no_zero s
            && (length ss) == 9
            && foldr (\x y -> length x == 1 && y) True ss
            where
                s = show a ++ show b ++ show (a*b)
                ss = group $ sort s
        no_zero (x:xs)
            | x == '0'  = False
            | null xs   = True
            | otherwise = no_zero xs

Problem 33

Discover all the fractions with an unorthodox cancelling method.

Solution:

import Ratio

problem_33 = denominator (product $ rs ++ rs')

rs = [(x%y) | a <- [0..9], b <- [1..9], c <- [1..9], let x = 10*a + c, let y = 10*c + b, x /= y, x%y < 1, x%y == a%b]

rs' = filter (<1) $ map (\x -> denominator x % numerator x) rs

Problem 34

Find the sum of all numbers which are equal to the sum of the factorial of their digits.

Solution:

import Data.Char
problem_34 = sum [ x | x <- [3..100000], x == facsum x ]
    where facsum = sum . map (product . enumFromTo 1 . digitToInt) . show

Problem 35

How many circular primes are there below one million?

Solution:

import Data.List (tails, (\\))

primes :: [Integer]
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]

primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
                        | otherwise      = factor m ps

isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
                (_:_:_)   -> False
                _         -> True

permutations :: Integer -> [Integer]
permutations n = take l $ map (read . take l) $ tails $ take (2*l -1) $ cycle s
    where
        s = show n
        l = length s

circular_primes :: [Integer] -> [Integer]
circular_primes []     = []
circular_primes (x:xs)
    | all isPrime p = x :  circular_primes xs
    | otherwise     = circular_primes xs
    where
        p = permutations x

problem_35 :: Int
problem_35 = length $ circular_primes $ takeWhile (<1000000) primes

Problem 36

Find the sum of all numbers less than one million, which are palindromic in base 10 and base 2.

Solution:

import Numeric
import Data.Char

showBin = flip (showIntAtBase 2 intToDigit) ""

isPalindrome x = x == reverse x

problem_36 = sum [x | x <- [1,3..1000000], isPalindrome (show x), isPalindrome (showBin x)]

Problem 37

Find the sum of all eleven primes that are both truncatable from left to right and right to left.

Solution:

import Data.List (tails, inits, nub)

primes :: [Integer]
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]

primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
                        | otherwise      = factor m ps

isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
                (_:_:_)   -> False
                _         -> True

truncs :: Integer -> [Integer]
truncs n = nub . map read $ (take l . tail . tails) s ++ (take l . tail . inits) s
    where
        l = length s - 1
        s = show n

problem_37 = sum $ take 11 [x | x <- dropWhile (<=9) primes, all isPrime (truncs x)]

Problem 38

What is the largest 1 to 9 pandigital that can be formed by multiplying a fixed number by 1, 2, 3, ... ?

Solution:

problem_38 = maximum $ catMaybes [result | j <- [1..9999],
              let p2 = show j ++ show (2*j),
              let p3 = p2 ++ show (3*j),
              let p4 = p3 ++ show (4*j),
              let p5 = p4 ++ show (5*j),
              let result
                      | isPan p2 = Just p2
                      | isPan p3 = Just p3
                      | isPan p4 = Just p4
                      | isPan p5 = Just p5
                      | otherwise = Nothing]
  where isPan s = sort s == "123456789"

Other solution:

import Data.List

mult n i vs | length (concat vs) >= 9 = concat vs
            | otherwise             = mult n (i+1) (vs ++ [show (n * i)])

problem_38 :: Int
problem_38 = maximum $ map read $ filter ((['1'..'9'] ==) .sort) $ [ mult n 1 [] | n <- [2..9999] ]

Problem 39

If p is the perimeter of a right angle triangle, {a, b, c}, which value, for p ≤ 1000, has the most solutions?

Solution: We use the well known formula to generate primitive Pythagorean triples. All we need are the perimeters, and they have to be scaled to produce all triples in the problem space.

problem_39 = head $ perims !! indexMax
    where  perims = group
                    $ sort [n*p | p <- pTriples, n <- [1..1000 `div` p]]
           counts = map length perims
           Just indexMax = findIndex (== (maximum counts)) $ counts
           pTriples = [p |
                       n <- [1..floor (sqrt 1000)],
                       m <- [n+1..floor (sqrt 1000)],
                       even n || even m,
                       gcd n m == 1,
                       let a = m^2 - n^2,
                       let b = 2*m*n,
                       let c = m^2 + n^2,
                       let p = a + b + c,
                       p < 1000]

Problem 40

Finding the nth digit of the fractional part of the irrational number.

Solution:

problem_40 = (d 1)*(d 10)*(d 100)*(d 1000)*(d 10000)*(d 100000)*(d 1000000)
    where n = concat [show n | n <- [1..]]
          d j = Data.Char.digitToInt (n !! (j-1))