Difference between revisions of "Euler problems/31 to 40"

From HaskellWiki
Jump to: navigation, search
(Problem 31: which is twice faster)
 
(29 intermediate revisions by 12 users not shown)
Line 4: Line 4:
 
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>
problem_31 =
 
  +
p31 = length $ g 200 [200,100,50,20,10,5,2,1]
ways [1,2,5,10,20,50,100,200] !!200
 
  +
where
where
 
  +
g 0 _ = [[]] -- exactly one way to get 0 sum, with no coins at all
ways [] = 1 : repeat 0
 
  +
g n [] = [] -- no way to sum up no coins to a non-zero sum
ways (coin:coins) =n
+
g n coins@(c:rest)
where
+
| c <= n = map (c:) (g (n-c) coins) -- with the top coin
n = zipWith (+) (ways coins) (take coin (repeat 0) ++ n)
+
++ 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>
   
Line 21: Line 22:
 
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)
zipWith (++) (map (map (p:)) with)
+
rich
rich
 
 
in with
 
in with
 
) ([[]] : repeat [])
 
) ([[]] : repeat [])
   
problem_31 =
+
problem_31 = length $ combinations coins !! 200
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>
 
</haskell>
   
Line 36: Line 37:
 
<haskell>
 
<haskell>
 
import Control.Monad
 
import Control.Monad
  +
 
combs 0 xs = [([],xs)]
 
combs 0 xs = [([],xs)]
combs n xs = [(y:ys,rest)|y<-xs, (ys,rest)<-combs (n-1) (delete y xs)]
+
combs n xs = [(y:ys,rest) | y <- xs, (ys,rest) <- combs (n-1) (delete y xs)]
   
 
l2n :: (Integral a) => [a] -> a
 
l2n :: (Integral a) => [a] -> a
Line 45: Line 47:
   
 
explode :: (Integral a) => a -> [a]
 
explode :: (Integral a) => a -> [a]
explode =
 
  +
explode = unfoldr (\a -> if a==0 then Nothing else Just . swap $ quotRem a 10)
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
   
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_32 = sum pandigiticals
 
</haskell>
 
</haskell>
Line 64: Line 66:
 
<haskell>
 
<haskell>
 
import Data.Ratio
 
import Data.Ratio
problem_33 = denominator $product $ rs
+
problem_33 = denominator . product $ rs
 
{-
 
{-
 
xy/yz = x/z
 
xy/yz = x/z
Line 70: Line 72:
 
9xz + yz = 10xy
 
9xz + yz = 10xy
 
-}
 
-}
rs=[(10*x+y)%(10*y+z) |
+
rs = [(10*x+y)%(10*y+z) | x <- t,
x <- t,
+
y <- t,
y <- t,
+
z <- t,
z <- t,
+
x /= y ,
x /= y ,
+
(9*x*z) + (y*z) == (10*x*y)]
(9*x*z) + (y*z) == (10*x*y)
+
where t = [1..9]
]
+
</haskell>
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
  +
<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>
 
</haskell>
   
Line 86: Line 88:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.Map (fromList ,(!))
+
import Data.Char
digits n
+
problem_34 = sum [ x | x <- [3..100000], x == facsum x ]
{- 123->[3,2,1]
+
where facsum = sum . map (product . enumFromTo 1 . digitToInt) . show
-}
+
|n<10=[n]
 
|otherwise= y:digits x
 
where
 
(x,y)=divMod n 10
 
-- 123 ->321
 
problem_34 =
 
sum[ x | x <- [3..100000], x == facsum x ]
 
where
 
fact n = product [1..n]
 
fac=fromList [(a,fact a)|a<-[0..9]]
 
facsum x= sum [fac!a|a<-digits x]
 
 
</haskell>
 
</haskell>
   
Here's another (slighly simpler) way:
 
  +
Another way:
  +
 
<haskell>
 
<haskell>
import Data.Char
+
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
   
fac n = product [1..n]
 
  +
intToList n = reverse $ unfoldr
  +
(\x -> if x == 0 then Nothing else Just (x `mod` 10, x `div` 10)) n
   
digits n = map digitToInt $ show n
 
  +
isCurious (n,l) = sort (intToList n) == l
   
sum_fac n = sum $ map fac $ digits n
 
  +
-- Turn a list into the sum of the factorials of the digits
  +
factorialSum l = sum $ map fac l
   
problem_34_v2 = sum [ x | x <- [3..10^5], x == sum_fac x ]
 
  +
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"&gt;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] ==
 
== [http://projecteuler.net/index.php?section=problems&id=35 Problem 35] ==
Line 109: Line 117:
   
 
Solution:
 
Solution:
millerRabinPrimality on the [[Prime_numbers]] page
 
 
<haskell>
 
<haskell>
isPrime x
 
  +
import Data.List (tails, (\\))
|x==1=False
 
  +
|x==2=True
 
  +
primes :: [Integer]
|x==3=True
 
  +
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
|otherwise=millerRabinPrimality x 2
 
  +
permutations n =
 
  +
primeFactors :: Integer -> [Integer]
take l $ map (read . take l) $
 
  +
primeFactors n = factor n primes
tails $ take (2*l -1) $ cycle s
 
 
where
 
where
s = show n
 
  +
factor _ [] = []
l = length s
 
  +
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 [] = []
 
circular_primes (x:xs)
 
circular_primes (x:xs)
Line 127: Line 149:
 
| otherwise = circular_primes xs
 
| otherwise = circular_primes xs
 
where
 
where
p = permutations x
+
p = permutations x
x=[1,3,7,9]
+
dmm=(\x y->x*10+y)
+
problem_35 :: Int
x3=[foldl dmm 0 [a,b,c]|a<-x,b<-x,c<-x]
+
problem_35 = length $ circular_primes $ takeWhile (<1000000) primes
x4=[foldl dmm 0 [a,b,c,d]|a<-x,b<-x,c<-x,d<-x]
 
x5=[foldl dmm 0 [a,b,c,d,e]|a<-x,b<-x,c<-x,d<-x,e<-x]
 
x6=[foldl dmm 0 [a,b,c,d,e,f]|a<-x,b<-x,c<-x,d<-x,e<-x,f<-x]
 
problem_35 =
 
(+13)$length $ circular_primes $ [a|a<-foldl (++) [] [x3,x4,x5,x6],isPrime a]
 
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=problems&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
Find the sum of all numbers less than one million, which are palindromic in base 10 and base 2.
 
  +
hence composite, we get: (HenryLaxen 2008-02-27)
   
Solution:
 
 
<haskell>
 
<haskell>
isPalin [] = True
 
  +
import Control.Monad (replicateM)
isPalin [a] = True
 
  +
isPalin (x:xs) =
 
  +
canBeCircularPrimeList = [1,3,7,9]
if x == last xs then isPalin $ sansLast xs else False
 
  +
where
 
  +
listToInt n = foldl (\x y -> 10*x+y) 0 n
sansLast xs = reverse $ tail $ reverse xs
 
  +
rot n l = y ++ x where (x,y) = splitAt n l
toBase2 0 = []
 
  +
allrots l = map (\x -> rot x l) [0..(length l)-1]
toBase2 x = (show $ mod x 2) : toBase2 (div x 2)
 
  +
isCircular l = all (isPrime . listToInt) $ allrots l
isbothPalin x =
 
  +
circular 1 = [[2],[3],[5],[7]] -- a slightly special case
isPalin (show x) && isPalin (toBase2 x)
 
  +
circular n = filter isCircular $ replicateM n canBeCircularPrimeList
problem_36=
 
  +
sum $ filter isbothPalin $ filter (not.even) [1..1000000]
 
  +
problem_35 = length $ concatMap circular [1..6]
 
</haskell>
 
</haskell>
   
Alternate Solution:
 
  +
  +
== [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.
  +
  +
Solution:
 
<haskell>
 
<haskell>
 
import Numeric
 
import Numeric
 
import Data.Char
 
import Data.Char
 
  +
  +
showBin = flip (showIntAtBase 2 intToDigit) ""
  +
 
isPalindrome x = x == reverse x
 
isPalindrome x = x == reverse x
 
  +
showBin n = showIntAtBase 2 intToDigit n ""
 
  +
problem_36 = sum [x | x <- [1,3..1000000], isPalindrome (show x), isPalindrome (showBin x)]
 
problem_36_v2 = sum [ n | n <- [1,3..10^6-1],
 
isPalindrome (show n) &&
 
isPalindrome (showBin n)]
 
 
</haskell>
 
</haskell>
   
Line 171: Line 194:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
-- isPrime in p35
 
  +
import Data.List (tails, inits, nub)
clist n =
 
  +
filter isLeftTruncatable $ if isPrime n then n:ns else []
 
  +
primes :: [Integer]
  +
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
  +
  +
primeFactors :: Integer -> [Integer]
  +
primeFactors n = factor n primes
 
where
 
where
ns = concatMap (clist . ((10*n) +)) [1,3,7,9]
 
  +
factor _ [] = []
  +
factor m (p:ps) | p*p > m = [m]
  +
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
  +
| otherwise = factor m ps
 
 
isLeftTruncatable =
 
  +
isPrime :: Integer -> Bool
all isPrime . map read . init . tail . tails . show
 
  +
isPrime 1 = False
problem_37 =
 
  +
isPrime n = case (primeFactors n) of
sum $ filter (>=10) $ concatMap clist [2,3,5,7]
 
  +
(_:_:_) -> 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>
  +
  +
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>
  +
   
 
== [http://projecteuler.net/index.php?section=problems&id=38 Problem 38] ==
 
== [http://projecteuler.net/index.php?section=problems&id=38 Problem 38] ==
Line 194: Line 250:
 
| otherwise = mult n (i+1) (vs ++ [show (n * i)])
 
| otherwise = mult n (i+1) (vs ++ [show (n * i)])
   
problem_38 =
+
problem_38 :: Int
maximum $ map read $ filter
+
problem_38 = maximum . map read . filter ((['1'..'9'] ==) . sort)
((['1'..'9'] ==) .sort) $
+
$ [mult n 1 [] | n <- [2..9999]]
[ mult n 1 [] | n <- [2..9999] ]
 
 
</haskell>
 
</haskell>
   
Line 205: Line 261:
 
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 =
+
problem_39 = head $ perims !! indexMax
head $ perims !! indexMax
+
where perims = group
where
+
$ sort [n*p | p <- pTriples, n <- [1..1000 `div` p]]
perims = group $ sort [n*p | p <- pTriples, n <- [1..1000 `div` p]]
+
counts = map length perims
counts = map length perims
+
Just indexMax = elemIndex (maximum counts) $ counts
Just indexMax = findIndex (== (maximum counts)) $ counts
+
pTriples = [p |
pTriples =
+
n <- [1..floor (sqrt 1000)],
[p |
+
m <- [n+1..floor (sqrt 1000)],
n <- [1..floor (sqrt 1000)],
+
even n || even m,
m <- [n+1..floor (sqrt 1000)],
+
gcd n m == 1,
even n || even m,
+
let a = m^2 - n^2,
gcd n m == 1,
+
let b = 2*m*n,
let a = m^2 - n^2,
+
let c = m^2 + n^2,
let b = 2*m*n,
+
let p = a + b + c,
let c = m^2 + n^2,
+
p < 1000]
let p = a + b + c,
 
p < 1000
 
]
 
 
</haskell>
 
</haskell>
   
Line 227: Line 283:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
takeLots :: [Int] -> [a] -> [a]
 
  +
problem_40 = (d 1)*(d 10)*(d 100)*(d 1000)*(d 10000)*(d 100000)*(d 1000000)
takeLots =
 
  +
where n = concat [show n | n <- [1..]]
t 1
 
  +
d j = Data.Char.digitToInt (n !! (j-1))
where
 
t i [] _ = []
 
t i jj@(j:js) (x:xs)
 
| i == j = x : t (i+1) js xs
 
| otherwise = t (i+1) jj xs
 
 
digitos :: [Int]
 
digitos =
 
d [1]
 
where
 
d k = reverse k ++ d (mais k)
 
mais (9:is) = 0 : mais is
 
mais (i:is) = (i+1) : is
 
mais [] = [1]
 
 
problem_40 =
 
product $ takeLots [10^n | n <- [0..6]] digitos
 
</haskell>
 
 
Here's how I did it, I think this is much easier to read:
 
 
<haskell>
 
num = concatMap show [1..]
 
 
problem_40_v2 = product $ map (\x -> digitToInt (num !! (10^x-1))) [0..6]
 
 
</haskell>
 
</haskell>

Latest revision as of 09:03, 19 September 2014

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 non-zero sum
    g n coins@(c:rest) 
      | c <= n = map (c:) (g (n-c) 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 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

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

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 !! (j-1))