Personal tools

Euler problems/31 to 40

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 6: Line 6:
 
This is the naive doubly recursive solution. Speed would be greatly improved by use of [[memoization]], dynamic programming, or the closed form.
 
This is the naive doubly recursive solution. Speed would be greatly improved by use of [[memoization]], dynamic programming, or the closed form.
 
<haskell>
 
<haskell>
problem_31 = pence 200 [1,2,5,10,20,50,100,200]
+
problem_31 =
where pence 0 _ = 1
+
pence 200 [1,2,5,10,20,50,100,200]
pence n [] = 0
+
where
pence n denominations@(d:ds)
+
pence 0 _ = 1
| n < d = 0
+
pence n [] = 0
| otherwise = pence (n - d) denominations
+
pence n denominations@(d:ds)
+ pence n ds
+
| n < d = 0
  +
| otherwise = pence (n - d) denominations + pence n ds
 
</haskell>
 
</haskell>
   
Line 27: Line 27:
 
) ([[]] : repeat [])
 
) ([[]] : repeat [])
   
problem_31 = length $ combinations coins !! 200
+
problem_31 =
  +
length $ combinations coins !! 200
 
</haskell>
 
</haskell>
   
Line 35: Line 35:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_32 = sum $ nub $ map (\(a, b) -> a * b) multiplicands
+
problem_32 =
  +
sum $ nub $ map (\(a, b) -> a * b) multiplicands
 
where
 
where
multiplicands =
+
multiplicands =
[(a,b)| a <- [2..5000], b <- [a..(9999 `div` a)], check a b]
+
[(a,b)| a <- [2..5000], b <- [a..(9999 `div` a)], check a b]
check a b =
+
check a b =
no_zero s
+
no_zero s
&& (length ss) == 9
+
&& (length ss) == 9
&& foldr (\x y -> length x == 1 && y) True ss
+
&& foldr (\x y -> length x == 1 && y) True ss
where
+
where
s = show a ++ show b ++ show (a*b)
+
s = show a ++ show b ++ show (a*b)
ss = group $ sort s
+
ss = group $ sort s
no_zero (x:xs)
+
no_zero (x:xs)
| x == '0' = False
+
| x == '0' = False
| null xs = True
+
| null xs = True
| otherwise = no_zero xs
+
| otherwise = no_zero xs
 
</haskell>
 
</haskell>
   
Line 72: Line 72:
 
]
 
]
   
rs' = filter (<1) $ map (\x -> denominator x % numerator x) rs
+
rs' =
  +
filter (<1) $ map (\x -> denominator x % numerator x) rs
 
</haskell>
 
</haskell>
   
Line 81: Line 81:
 
<haskell>
 
<haskell>
 
import Data.Char
 
import Data.Char
problem_34 = sum [ x | x <- [3..100000], x == facsum x ]
+
problem_34 =
where facsum = sum . map (product . enumFromTo 1 . digitToInt) . show
+
sum [ x | x <- [3..100000], x == facsum x ]
  +
where
  +
facsum = sum . map (product . enumFromTo 1 . digitToInt) . show
 
</haskell>
 
</haskell>
   
Line 92: Line 92:
 
import Data.List (tails, (\\))
 
import Data.List (tails, (\\))
   
primes :: [Integer]
+
primes =
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
+
2 : filter ((==1) . length . primeFactors) [3,5..]
+
primeFactors n =
primeFactors :: Integer -> [Integer]
+
factor n primes
primeFactors n = factor n primes
 
 
where
 
where
factor _ [] = []
+
factor n (p:ps)
factor m (p:ps) | p*p > m = [m]
+
| p*p > n = [n]
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
+
| n `mod` p == 0 = p : factor (n `div` p) (p:ps)
| otherwise = factor m ps
+
| otherwise = factor n ps
+
isPrime
isPrime :: Integer -> Bool
+
|1 = False
isPrime 1 = False
+
|otherwise=
isPrime n = case (primeFactors n) of
+
case (primeFactors n) of
(_:_:_) -> False
+
(_:_:_) -> False
_ -> True
+
_ -> True
+
permutations n =
permutations :: Integer -> [Integer]
+
take l $ map (read . take l) $
permutations n = take l $ map (read . take l) $ tails $ take (2*l -1) $ cycle s
+
tails $ take (2*l -1) $ cycle s
 
where
 
where
s = show n
+
s = show n
l = length s
+
l = length s
 
circular_primes :: [Integer] -> [Integer]
 
 
circular_primes [] = []
 
circular_primes [] = []
 
circular_primes (x:xs)
 
circular_primes (x:xs)
Line 118: Line 118:
 
| otherwise = circular_primes xs
 
| otherwise = circular_primes xs
 
where
 
where
p = permutations x
+
p = permutations x
   
problem_35 :: Int
+
problem_35 =
problem_35 = length $ circular_primes $ takeWhile (<1000000) primes
+
length $ circular_primes $ takeWhile (<1000000) primes
 
</haskell>
 
</haskell>
   
Line 132: Line 132:
 
import Data.Char
 
import Data.Char
   
showBin = flip (showIntAtBase 2 intToDigit) ""
+
showBin =
  +
flip (showIntAtBase 2 intToDigit) ""
   
isPalindrome x = x == reverse x
+
isPalindrome x =
  +
x == reverse x
   
problem_36 = sum [x |
+
problem_36 =
  +
sum [x |
 
x <- [1,3..1000000],
 
x <- [1,3..1000000],
 
isPalindrome (show x),
 
isPalindrome (show x),
Line 150: Line 150:
 
import Data.List (tails, inits, nub)
 
import Data.List (tails, inits, nub)
   
primes :: [Integer]
+
truncs n =
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
+
nub . map read $
 
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
 
(take l . tail . tails) s ++ (take l . tail . inits) s
 
where
 
where
Line 157: Line 157:
 
s = show n
 
s = show n
   
problem_37 = sum $ take 11 [x |
+
problem_37 =
  +
sum $ take 11 [x |
 
x <- dropWhile (<=9) primes,
 
x <- dropWhile (<=9) primes,
 
all isPrime (truncs x)
 
all isPrime (truncs x)
Line 169: Line 169:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_38 = maximum $ catMaybes [result | j <- [1..9999],
+
problem_38 =
let p2 = show j ++ show (2*j),
+
maximum $ catMaybes [result | j <- [1..9999],
let p3 = p2 ++ show (3*j),
+
let p2 = show j ++ show (2*j),
let p4 = p3 ++ show (4*j),
+
let p3 = p2 ++ show (3*j),
let p5 = p4 ++ show (5*j),
+
let p4 = p3 ++ show (4*j),
let result
+
let p5 = p4 ++ show (5*j),
| isPan p2 = Just p2
+
let result
| isPan p3 = Just p3
+
| isPan p2 = Just p2
| isPan p4 = Just p4
+
| isPan p3 = Just p3
| isPan p5 = Just p5
+
| isPan p4 = Just p4
| otherwise = Nothing]
+
| isPan p5 = Just p5
where isPan s = sort s == "123456789"
+
| otherwise = Nothing
  +
]
  +
where
  +
isPan s = sort s == "123456789"
 
</haskell>
 
</haskell>
   
Line 187: Line 187:
 
import Data.List
 
import Data.List
   
mult n i vs | length (concat vs) >= 9 = concat vs
+
mult n i vs
| otherwise = mult n (i+1) (vs ++ [show (n * i)])
+
| length (concat vs) >= 9 = concat vs
  +
| otherwise = mult n (i+1) (vs ++ [show (n * i)])
   
problem_38 :: Int
+
problem_38 =
problem_38 = maximum $ map read $ filter
+
maximum $ map read $ filter
 
((['1'..'9'] ==) .sort) $
 
((['1'..'9'] ==) .sort) $
 
[ mult n 1 [] | n <- [2..9999] ]
 
[ mult n 1 [] | n <- [2..9999] ]
Line 202: Line 202:
 
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.
 
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.
 
<haskell>
 
<haskell>
problem_39 = head $ perims !! indexMax
+
problem_39 =
where perims = group
+
head $ perims !! indexMax
$ sort [n*p | p <- pTriples, n <- [1..1000 `div` p]]
+
where
counts = map length perims
+
perims = group $ sort [n*p | p <- pTriples, n <- [1..1000 `div` p]]
Just indexMax = findIndex (== (maximum counts)) $ counts
+
counts = map length perims
pTriples = [p |
+
Just indexMax = findIndex (== (maximum counts)) $ counts
n <- [1..floor (sqrt 1000)],
+
pTriples =
m <- [n+1..floor (sqrt 1000)],
+
[p |
even n || even m,
+
n <- [1..floor (sqrt 1000)],
gcd n m == 1,
+
m <- [n+1..floor (sqrt 1000)],
let a = m^2 - n^2,
+
even n || even m,
let b = 2*m*n,
+
gcd n m == 1,
let c = m^2 + n^2,
+
let a = m^2 - n^2,
let p = a + b + c,
+
let b = 2*m*n,
p < 1000]
+
let c = m^2 + n^2,
  +
let p = a + b + c,
  +
p < 1000
  +
]
 
</haskell>
 
</haskell>
   

Revision as of 00:44, 17 January 2008

Contents

1 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

2 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

3 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

4 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

5 Problem 35

How many circular primes are there below one million?

Solution:

import Data.List (tails, (\\))
 
primes = 
    2 : filter ((==1) . length . primeFactors) [3,5..]
primeFactors n =
    factor n primes
    where
    factor n (p:ps) 
        | p*p > n        = [n]
        | n `mod` p == 0 = p : factor (n `div` p) (p:ps)
        | otherwise      = factor n ps
isPrime 
    |1 = False
    |otherwise=
        case (primeFactors n) of
            (_:_:_)   -> False
            _         -> True
permutations n = 
    take l $ map (read . take l) $ 
    tails $ take (2*l -1) $ cycle s
    where
    s = show n
    l = length s
circular_primes []     = []
circular_primes (x:xs)
    | all isPrime p = x :  circular_primes xs
    | otherwise     = circular_primes xs
    where
    p = permutations x
 
problem_35 = 
    length $ circular_primes $ takeWhile (<1000000) primes

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

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

8 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 = 
    maximum $ map read $ filter
    ((['1'..'9'] ==) .sort) $
    [ mult n 1 [] | n <- [2..9999] ]

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

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