# Euler problems/31 to 40

### From HaskellWiki

(→Problem 31) |
|||

(45 intermediate revisions by 16 users not shown) | |||

Line 1: | Line 1: | ||

− | [[Category:Programming exercise spoilers]] |
+ | == [http://projecteuler.net/index.php?section=problems&id=31 Problem 31] == |

− | == [http://projecteuler.net/index.php?section=view&id=31 Problem 31] == |
||

Investigating combinations of English currency denominations. |
Investigating combinations of English currency denominations. |
||

Solution: |
Solution: |
||

− | 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 = ways [1,2,5,10,20,50,100,200] !!200 |

− | where pence 0 _ = 1 |
+ | where ways [] = 1 : repeat 0 |

− | pence n [] = 0 |
+ | ways (coin:coins) =n |

− | pence n denominations@(d:ds) |
+ | where n = zipWith (+) (ways coins) (replicate coin 0 ++ n) |

− | | n < d = 0 |
||

− | | otherwise = pence (n - d) denominations |
||

− | + pence n ds |
||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=32 Problem 32] == |
+ | 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 : |

+ | <haskell> |
||

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

+ | </haskell> |
||

+ | |||

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

+ | <haskell> |
||

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

+ | </haskell> |
||

+ | |||

+ | The program above can be slightly modified as shown below so it just counts the combinations without generating them. |
||

+ | <haskell> |
||

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

+ | |||

+ | countCoins 1 _ = 1 |
||

+ | countCoins n x = sum $ map addCoin [0 .. x `div` coins !! pred n] |
||

+ | where addCoin k = countCoins (pred n) (x - k * coins !! pred n) |
||

+ | |||

+ | problem_31 = countCoins (length coins) 200 |
||

+ | </haskell> |
||

+ | |||

+ | == [http://projecteuler.net/index.php?section=problems&id=32 Problem 32] == |
||

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

Solution: |
Solution: |
||

<haskell> |
<haskell> |
||

− | problem_32 = undefined |
+ | 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 |
||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=33 Problem 33] == |
+ | == [http://projecteuler.net/index.php?section=problems&id=33 Problem 33] == |

Discover all the fractions with an unorthodox cancelling method. |
Discover all the fractions with an unorthodox cancelling method. |
||

Solution: |
Solution: |
||

<haskell> |
<haskell> |
||

− | problem_33 = undefined |
+ | 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] |
||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=34 Problem 34] == |
+ | 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 |

+ | <haskell> |
||

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

+ | </haskell> |
||

+ | |||

+ | == [http://projecteuler.net/index.php?section=problems&id=34 Problem 34] == |
||

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

Line 36: | Line 36: | ||

problem_34 = sum [ x | x <- [3..100000], x == facsum x ] |
problem_34 = sum [ x | x <- [3..100000], x == facsum x ] |
||

where facsum = sum . map (product . enumFromTo 1 . digitToInt) . show |
where facsum = sum . map (product . enumFromTo 1 . digitToInt) . show |
||

+ | |||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=35 Problem 35] == |
+ | Another way: |

+ | |||

+ | <haskell> |
||

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

+ | </haskell> |
||

+ | (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) |
||

+ | |||

+ | == [http://projecteuler.net/index.php?section=problems&id=35 Problem 35] == |
||

How many circular primes are there below one million? |
How many circular primes are there below one million? |
||

Solution: |
Solution: |
||

<haskell> |
<haskell> |
||

− | problem_35 = undefined |
+ | 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 |
||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=36 Problem 36] == |
+ | 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) |
||

+ | |||

+ | <haskell> |
||

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

+ | </haskell> |
||

+ | |||

+ | |||

+ | == [http://projecteuler.net/index.php?section=problems&id=36 Problem 36] == |
||

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

Solution: |
Solution: |
||

<haskell> |
<haskell> |
||

− | problem_36 = undefined |
+ | 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)] |
||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=37 Problem 37] == |
+ | == [http://projecteuler.net/index.php?section=problems&id=37 Problem 37] == |

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

Solution: |
Solution: |
||

<haskell> |
<haskell> |
||

− | problem_37 = undefined |
+ | 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)] |
||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=38 Problem 38] == |
+ | Or, more cleanly: |

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

− | Solution: |
||

<haskell> |
<haskell> |
||

− | problem_38 = maximum $ catMaybes [result | j <- [1..9999], |
+ | import Data.Numbers.Primes (primes, isPrime) |

− | let p2 = show j ++ show (2*j), |
+ | |

− | let p3 = p2 ++ show (3*j), |
+ | test' :: Int -> Int -> (Int -> Int -> Int) -> Bool |

− | let p4 = p3 ++ show (4*j), |
+ | test' n d f |

− | let p5 = p4 ++ show (5*j), |
+ | | d > n = True |

− | let result |
+ | | otherwise = isPrime (f n d) && test' n (10*d) f |

− | | isPan p2 = Just p2 |
+ | |

− | | isPan p3 = Just p3 |
+ | test :: Int -> Bool |

− | | isPan p4 = Just p4 |
+ | test n = test' n 10 (mod) && test' n 10 (div) |

− | | isPan p5 = Just p5 |
+ | |

− | | otherwise = Nothing] |
+ | problem_37 = sum $ take 11 $ filter test $ filter (>7) primes |

− | where isPan s = sort s == "123456789" |
||

</haskell> |
</haskell> |
||

− | Other solution: |
+ | |

+ | == [http://projecteuler.net/index.php?section=problems&id=38 Problem 38] == |
||

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

+ | |||

+ | Solution: |
||

<haskell> |
<haskell> |
||

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

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

+ | $ [mult n 1 [] | n <- [2..9999]] |
||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=39 Problem 39] == |
+ | == [http://projecteuler.net/index.php?section=problems&id=39 Problem 39] == |

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

Line 100: | Line 100: | ||

$ sort [n*p | p <- pTriples, n <- [1..1000 `div` p]] |
$ sort [n*p | p <- pTriples, n <- [1..1000 `div` p]] |
||

counts = map length perims |
counts = map length perims |
||

− | Just indexMax = findIndex (== (maximum counts)) $ counts |
+ | Just indexMax = elemIndex (maximum counts) $ counts |

pTriples = [p | |
pTriples = [p | |
||

n <- [1..floor (sqrt 1000)], |
n <- [1..floor (sqrt 1000)], |
||

Line 113: | Line 113: | ||

</haskell> |
</haskell> |
||

− | == [http://projecteuler.net/index.php?section=view&id=40 Problem 40] == |
+ | == [http://projecteuler.net/index.php?section=problems&id=40 Problem 40] == |

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

Line 122: | Line 122: | ||

d j = Data.Char.digitToInt (n !! (j-1)) |
d j = Data.Char.digitToInt (n !! (j-1)) |
||

</haskell> |
</haskell> |
||

− | |||

− | [[Category:Tutorials]] |
||

− | [[Category:Code]] |

## Latest revision as of 00:16, 27 September 2012

## Contents |

## [edit] 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 = 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

The program above can be slightly modified as shown below so it just counts the combinations without generating them.

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

## [edit] 2 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

## [edit] 3 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)

## [edit] 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

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)

## [edit] 5 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]

## [edit] 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)]

## [edit] 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) 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)]

Or, more cleanly:

import Data.Numbers.Primes (primes, isPrime) test' :: Int -> Int -> (Int -> Int -> Int) -> Bool test' n d f | d > n = True | otherwise = isPrime (f n d) && test' n (10*d) f test :: Int -> Bool test n = test' n 10 (mod) && test' n 10 (div) problem_37 = sum $ take 11 $ filter test $ filter (>7) primes

## [edit] 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:

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

## [edit] 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 = 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]

## [edit] 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))