Difference between revisions of "Euler problems/31 to 40"
(Faster (and more beautiful) solution to problem 31) 
(→Problem 31: which is twice faster) 

(39 intermediate revisions by 15 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. 

+  The most straightforward solution, following the logical structure closely, actually generating the solutions (won't be the optimal one obviously by a long shot, but serves as an illustration, a development aid... runs in under 0.5 second on Ideone). We can make up the sum either with or without the most valuable coin: 

+  
<haskell> 
<haskell> 

−  +  p31 = length $ g 200 [200,100,50,20,10,5,2,1] 

−  +  where 

−  +  g 0 _ = [[]]  exactly one way to get 0 sum, with no coins at all 

−  +  g n [] = []  no way to sum up no coins to a nonzero sum 

−  +  g n coins@(c:rest) 

−  +   c <= n = map (c:) (g (nc) coins)  with the top coin 

−  +  ++ g n rest 

+   otherwise = g n rest  without it 

+  </haskell> 

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

+  <haskell> 

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

</haskell> 
</haskell> 

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

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

combinations = foldl (\without p > 
combinations = foldl (\without p > 

let (poor,rich) = splitAt p without 
let (poor,rich) = splitAt p without 

−  with = poor ++ 
+  with = poor ++ zipWith (++) (map (map (p:)) with) 
−  +  rich 

−  rich 

in with 
in with 

) ([[]] : repeat []) 
) ([[]] : repeat []) 

−  problem_31 = length $ combinations 
+  problem_31 = length $ combinations coins !! 200 
</haskell> 
</haskell> 

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

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

+  <haskell> 

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

+  
+  withcoins 1 x = [[x]] 

+  withcoins n x = concatMap addCoin [0 .. x `div` coins!!(n1)] 

+  where addCoin k = map (++[k]) (withcoins (n1) (x  k*coins!!(n1)) ) 

+  
+  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 = sum $ nub $ map (\(a, b) > a * b) multiplicands 

+  import Control.Monad 

−  where 

+  
−  multiplicands = 

+  combs 0 xs = [([],xs)] 

−  +  combs n xs = [(y:ys,rest)  y < xs, (ys,rest) < combs (n1) (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= 
+  == [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> 

−  import Ratio 
+  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> 

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

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

−  
+  <haskell> 

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

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

−  == [http://projecteuler.net/index.php?section= 
+  == [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 74:  Line 100:  
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> 

+  
+  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 (k1) (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> 
</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= 
+  == [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? 

Line 82:  Line 148:  
<haskell> 
<haskell> 

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

−  
+  
primes :: [Integer] 
primes :: [Integer] 

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

−  
+  
primeFactors :: Integer > [Integer] 
primeFactors :: Integer > [Integer] 

primeFactors n = factor n primes 
primeFactors n = factor n primes 

Line 93:  Line 159:  
 m `mod` p == 0 = p : factor (m `div` p) (p:ps) 
 m `mod` p == 0 = p : factor (m `div` p) (p:ps) 

 otherwise = factor m ps 
 otherwise = factor m ps 

−  
+  
isPrime :: Integer > Bool 
isPrime :: Integer > Bool 

isPrime 1 = False 
isPrime 1 = False 

Line 99:  Line 165:  
(_:_:_) > False 
(_:_:_) > False 

_ > True 
_ > True 

−  
+  
permutations :: Integer > [Integer] 
permutations :: Integer > [Integer] 

permutations n = take l $ map (read . take l) $ tails $ take (2*l 1) $ cycle s 
permutations n = take l $ map (read . take l) $ tails $ take (2*l 1) $ cycle s 

Line 105:  Line 171:  
s = show n 
s = show n 

l = length s 
l = length s 

−  
+  
circular_primes :: [Integer] > [Integer] 
circular_primes :: [Integer] > [Integer] 

circular_primes [] = [] 
circular_primes [] = [] 

Line 113:  Line 179:  
where 
where 

p = permutations x 
p = permutations x 

−  
+  
problem_35 :: Int 
problem_35 :: Int 

problem_35 = length $ circular_primes $ takeWhile (<1000000) primes 
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 20080227) 

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

Line 125:  Line 210:  
import Numeric 
import Numeric 

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  x < [1,3..1000000], isPalindrome (show x), isPalindrome (showBin x)] 
problem_36 = sum [x  x < [1,3..1000000], isPalindrome (show x), isPalindrome (showBin x)] 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [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. 

Line 139:  Line 224:  
<haskell> 
<haskell> 

import Data.List (tails, inits, nub) 
import Data.List (tails, inits, nub) 

−  
+  
primes :: [Integer] 
primes :: [Integer] 

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

−  
+  
primeFactors :: Integer > [Integer] 
primeFactors :: Integer > [Integer] 

primeFactors n = factor n primes 
primeFactors n = factor n primes 

Line 150:  Line 235:  
 m `mod` p == 0 = p : factor (m `div` p) (p:ps) 
 m `mod` p == 0 = p : factor (m `div` p) (p:ps) 

 otherwise = factor m ps 
 otherwise = factor m ps 

−  
+  
isPrime :: Integer > Bool 
isPrime :: Integer > Bool 

isPrime 1 = False 
isPrime 1 = False 

Line 156:  Line 241:  
(_:_:_) > False 
(_:_:_) > False 

_ > True 
_ > True 

−  
+  
truncs :: Integer > [Integer] 
truncs :: Integer > [Integer] 

truncs n = nub . map read $ (take l . tail . tails) s ++ (take l . tail . inits) s 
truncs n = nub . map read $ (take l . tail . tails) s ++ (take l . tail . inits) s 

Line 162:  Line 247:  
l = length s  1 
l = length s  1 

s = show n 
s = show n 

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

+  </haskell> 

+  Or, more cleanly: 

+  
+  <haskell> 

+  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 

</haskell> 
</haskell> 

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

+  
+  == [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, ... ? 
What is the largest 1 to 9 pandigital that can be formed by multiplying a fixed number by 1, 2, 3, ... ? 

Solution: 
Solution: 

−  <haskell> 

−  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" 

−  </haskell> 

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

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [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 207:  Line 293:  
$ 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 = 
+  Just indexMax = elemIndex (maximum counts) $ counts 
pTriples = [p  
pTriples = [p  

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

Line 220:  Line 306:  
</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section= 
+  == [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 229:  Line 315:  
d j = Data.Char.digitToInt (n !! (j1)) 
d j = Data.Char.digitToInt (n !! (j1)) 

</haskell> 
</haskell> 

−  
−  [[Category:Tutorials]] 

−  [[Category:Code]] 
Latest revision as of 09:03, 19 September 2014
Contents
Problem 31
Investigating combinations of English currency denominations.
Solution:
The most straightforward solution, following the logical structure closely, actually generating the solutions (won't be the optimal one obviously by a long shot, but serves as an illustration, a development aid... runs in under 0.5 second on Ideone). We can make up the sum either with or without the most valuable coin:
p31 = length $ g 200 [200,100,50,20,10,5,2,1]
where
g 0 _ = [[]]  exactly one way to get 0 sum, with no coins at all
g n [] = []  no way to sum up no coins to a nonzero sum
g n coins@(c:rest)
 c <= n = map (c:) (g (nc) coins)  with the top coin
++ g n rest
 otherwise = g n rest  without it
Here 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 20080222
coins = [1,2,5,10,20,50,100,200]
withcoins 1 x = [[x]]
withcoins n x = concatMap addCoin [0 .. x `div` coins!!(n1)]
where addCoin k = map (++[k]) (withcoins (n1) (x  k*coins!!(n1)) )
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
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 (n1) (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 20080234
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 (k1) (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 20080227)
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)]
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
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]]
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 !! (j1))