# 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 = ways [1,2,5,10,20,50,100,200] !!200
where ways [] = 1 : repeat 0
ways (coin:coins) =n
where n = zipWith (+) (ways coins) (replicate coin 0 ++ n)
```

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
```

The above may be *a beautiful solution*, but I couldn't understand it without major mental gymnastics. I would like to offer the following, which I hope will be easier to follow for ordinary *mentats* -- HenryLaxen 2008-02-22

```
coins = [1,2,5,10,20,50,100,200]
withcoins 1 x = [[x]]
withcoins n x = concatMap addCoin [0 .. x `div` coins!!(n-1)]
where addCoin k = map (++[k]) (withcoins (n-1) (x - k*coins!!(n-1)) )
problem_31 = length $ withcoins (length coins) 200
```

## Problem 32

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

Solution:

```
import Control.Monad
combs 0 xs = [([],xs)]
combs n xs = [(y:ys,rest) | y <- xs, (ys,rest) <- combs (n-1) (delete y xs)]
l2n :: (Integral a) => [a] -> a
l2n = foldl' (\a b -> 10*a+b) 0
swap (a,b) = (b,a)
explode :: (Integral a) => a -> [a]
explode = unfoldr (\a -> if a==0 then Nothing else Just . swap $ quotRem a 10)
pandigiticals =
nub $ do (beg,end) <- combs 5 [1..9]
n <- [1,2]
let (a,b) = splitAt n beg
res = l2n a * l2n b
guard $ sort (explode res) == end
return res
problem_32 = sum pandigiticals
```

## Problem 33

Discover all the fractions with an unorthodox cancelling method.

Solution:

```
import Data.Ratio
problem_33 = denominator . product $ rs
{-
xy/yz = x/z
(10x + y)/(10y+z) = x/z
9xz + yz = 10xy
-}
rs = [(10*x+y)%(10*y+z) | x <- t,
y <- t,
z <- t,
x /= y ,
(9*x*z) + (y*z) == (10*x*y)]
where t = [1..9]
```

That is okay, but why not let the computer do the *thinking* for you? Isn't this a little more directly expressive of the problem? -- HenryLaxen 2008-02-34

```
import Data.Ratio
problem_33 = denominator $ product
[ a%c | a<-[1..9], b<-[1..9], c<-[1..9],
isCurious a b c, a /= b && a/= c]
where isCurious a b c = ((10*a+b)%(10*b+c)) == (a%c)
```

## 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
```

Another way:

```
import Data.Array
import Data.List
{-
The key comes in realizing that N*9! < 10^N when N >= 9, so we
only have to check up to 9 digit integers. The other key is
that addition is commutative, so we only need to generate
combinations (with duplicates) of the sums of the various
factorials. These sums are the only potential "curious" sums.
-}
fac n = a!n
where a = listArray (0,9) (1:(scanl1 (*) [1..9]))
-- subsets of size k, including duplicates
combinationsOf 0 _ = [[]]
combinationsOf _ [] = []
combinationsOf k (x:xs) = map (x:)
(combinationsOf (k-1) (x:xs)) ++ combinationsOf k xs
intToList n = reverse $ unfoldr
(\x -> if x == 0 then Nothing else Just (x `mod` 10, x `div` 10)) n
isCurious (n,l) = sort (intToList n) == l
-- Turn a list into the sum of the factorials of the digits
factorialSum l = sum $ map fac l
possiblyCurious = map (\z -> (factorialSum z,z))
curious n = filter isCurious $ possiblyCurious $ combinationsOf n [0..9]
problem_34 = sum $ (fst . unzip) $ concatMap curious [2..9]
```

(The wiki formatting is messing up the unzip">unzip line above, it is correct in the version I typed in. It should of course just be fst . unzip)

## 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
```

Using isPrime from above, and observing that one that can greatly reduce the search space because no circular prime can contain an even number, nor a 5, since eventually such a digit will be at the end of the number, and hence composite, we get: (HenryLaxen 2008-02-27)

```
import Control.Monad (replicateM)
canBeCircularPrimeList = [1,3,7,9]
listToInt n = foldl (\x y -> 10*x+y) 0 n
rot n l = y ++ x where (x,y) = splitAt n l
allrots l = map (\x -> rot x l) [0..(length l)-1]
isCircular l = all (isPrime . listToInt) $ allrots l
circular 1 = [[2],[3],[5],[7]] -- a slightly special case
circular n = filter isCircular $ replicateM n canBeCircularPrimeList
problem_35 = length $ concatMap circular [1..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)]
```

## 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:

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

## 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 = elemIndex (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))
```