Personal tools

Euler problems/31 to 40

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 7: Line 7:
 
<haskell>
 
<haskell>
 
problem_31 =
 
problem_31 =
pence 200 [1,2,5,10,20,50,100,200]
+
ways [1,2,5,10,20,50,100,200] !!200
 
where
 
where
pence 0 _ = 1
+
ways [] = 1 : repeat 0
pence n [] = 0
+
ways (coin:coins) =n
pence n denominations@(d:ds)
+
where
| n < d = 0
+
n = zipWith (+) (ways coins) (take coin (repeat 0) ++ n)
| otherwise = pence (n - d) denominations + pence n ds
 
 
</haskell>
 
</haskell>
   
Line 36: Line 36:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_32 =
+
import Control.Monad
sum $ nub $ map (\(a, b) -> a * b) multiplicands
+
combs 0 xs = [([],xs)]
where
+
combs n xs = [(y:ys,rest)|y<-xs, (ys,rest)<-combs (n-1) (delete y xs)]
multiplicands =
+
[(a,b)| a <- [2..5000], b <- [a..(9999 `div` a)], check a b]
+
l2n :: (Integral a) => [a] -> a
check a b =
+
l2n = foldl' (\a b -> 10*a+b) 0
no_zero s
+
&& (length ss) == 9
+
swap (a,b) = (b,a)
&& foldr (\x y -> length x == 1 && y) True ss
+
where
+
explode :: (Integral a) => a -> [a]
s = show a ++ show b ++ show (a*b)
+
explode =
ss = group $ sort s
+
unfoldr (\a -> if a==0 then Nothing else Just $ swap $ quotRem a 10)
no_zero (x:xs)
+
| x == '0' = False
+
pandigiticals = nub $ do
| null xs = True
+
(beg,end) <- combs 5 [1..9]
| otherwise = no_zero xs
+
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>
   
Line 59: Line 59:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Ratio
+
import Data.Ratio
+
problem_33 = denominator $product $ rs
problem_33 = denominator (product $ rs ++ rs')
+
{-
+
xy/yz = x/z
rs = [(x%y) |
+
(10x + y)/(10y+z) = x/z
a <- [0..9],
+
9xz + yz = 10xy
b <- [1..9],
+
-}
c <- [1..9],
+
rs=[(10*x+y)%(10*y+z) |
let x = 10*a + c,
+
x <- t,
let y = 10*c + b,
+
y <- t,
x /= y,
+
z <- t,
x%y < 1,
+
x /= y ,
x%y == a%b
+
(9*x*z) + (y*z) == (10*x*y)
 
]
 
]
+
where
rs' =
+
t=[1..9]
filter (<1) $ map (\x -> denominator x % numerator x) rs
 
 
</haskell>
 
</haskell>
   
Line 82: Line 82:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.Char
+
import Data.Map (fromList ,(!))
  +
digits n
  +
{- 123->[3,2,1]
  +
-}
  +
|n<10=[n]
  +
|otherwise= y:digits x
  +
where
  +
(x,y)=divMod n 10
  +
-- 123 ->321
 
problem_34 =
 
problem_34 =
sum [ x | x <- [3..100000], x == facsum x ]
+
sum[ x | x <- [3..100000], x == facsum x ]
 
where
 
where
facsum = sum . map (product . enumFromTo 1 . digitToInt) . show
+
fact n = product [1..n]
  +
fac=fromList [(a,fact a)|a<-[0..9]]
  +
facsum x= sum [fac!a|a<-digits x]
 
</haskell>
 
</haskell>
   
Line 93: Line 93:
   
 
Solution:
 
Solution:
  +
millerRabinPrimality on the [[Prime_numbers]] page
 
<haskell>
 
<haskell>
import Data.List (tails, (\\))
+
isPrime x
+
|x==1=False
primes =
+
|x==2=True
2 : filter ((==1) . length . primeFactors) [3,5..]
+
|x==3=True
primeFactors n =
+
|otherwise=millerRabinPrimality x 2
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 =
 
permutations n =
 
take l $ map (read . take l) $
 
take l $ map (read . take l) $
Line 111: Line 112:
 
where
 
where
 
p = permutations x
 
p = permutations x
+
x=[1,3,7,9]
  +
dmm=(\x y->x*10+y)
  +
x3=[foldl dmm 0 [a,b,c]|a<-x,b<-x,c<-x]
  +
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 =
 
problem_35 =
length $ circular_primes $ takeWhile (<1000000) primes
+
(+13)$length $ circular_primes $ [a|a<-foldl (++) [] [x3,x4,x5,x6],isPrime a]
 
</haskell>
 
</haskell>
   
Line 121: Line 122:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Numeric
+
isPalin [] = True
import Data.Char
+
isPalin [a] = True
+
isPalin (x:xs) =
showBin =
+
if x == last xs then isPalin $ sansLast xs else False
flip (showIntAtBase 2 intToDigit) ""
+
where
+
sansLast xs = reverse $ tail $ reverse xs
isPalindrome x =
+
toBase2 0 = []
x == reverse x
+
toBase2 x = (show $ mod x 2) : toBase2 (div x 2)
+
isbothPalin x =
problem_36 =
+
isPalin (show x) && isPalin (toBase2 x)
sum [x |
+
problem_36=
x <- [1,3..1000000],
+
sum $ filter isbothPalin $ filter (not.even) [1..1000000]
isPalindrome (show x),
 
isPalindrome (showBin x)
 
]
 
 
</haskell>
 
</haskell>
   
Line 140: Line 141:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.List (tails, inits, nub)
+
-- isPrime in p35
+
clist n =
truncs n =
+
filter isLeftTruncatable $ if isPrime n then n:ns else []
nub . map read $
 
(take l . tail . tails) s ++ (take l . tail . inits) s
 
 
where
 
where
l = length s - 1
+
ns = concatMap (clist . ((10*n) +)) [1,3,7,9]
s = show n
+
+
isLeftTruncatable =
problem_37 =
+
all isPrime . map read . init . tail . tails . show
sum $ take 11 [x |
+
problem_37 =
x <- dropWhile (<=9) primes,
+
sum $ filter (>=10) $ concatMap clist [2,3,5,7]
all isPrime (truncs x)
 
]
 
 
 
</haskell>
 
</haskell>
   
Line 156: Line 157:
   
 
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
Line 219: Line 201:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
  +
takeLots :: [Int] -> [a] -> [a]
  +
takeLots =
  +
t 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 =
 
problem_40 =
(d 1)*(d 10)*(d 100)*(d 1000)*(d 10000)*(d 100000)*(d 1000000)
+
product $ takeLots [10^n | n <- [0..6]] digitos
where
 
n = concat [show n | n <- [1..]]
 
d j = Data.Char.digitToInt (n !! (j-1))
 
 
</haskell>
 
</haskell>

Revision as of 03:55, 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 = 
    ways [1,2,5,10,20,50,100,200] !!200
    where 
    ways [] = 1 : repeat 0
    ways (coin:coins) =n 
        where
        n = zipWith (+) (ways coins) (take coin (repeat 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

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

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]

4 Problem 34

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

Solution:

import Data.Map (fromList ,(!)) 
digits n 
{-  123->[3,2,1]
 -}
    |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]

5 Problem 35

How many circular primes are there below one million?

Solution: millerRabinPrimality on the Prime_numbers page

isPrime x
    |x==1=False
    |x==2=True
    |x==3=True
    |otherwise=millerRabinPrimality x 2
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
x=[1,3,7,9] 
dmm=(\x y->x*10+y)
x3=[foldl dmm 0 [a,b,c]|a<-x,b<-x,c<-x]
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]

6 Problem 36

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

Solution:

isPalin [] = True
isPalin [a] = True
isPalin (x:xs) = 
    if x == last xs then isPalin $ sansLast xs else False
	where 
    sansLast xs = reverse $ tail $ reverse xs
toBase2 0 = []
toBase2 x = (show $ mod x 2) : toBase2 (div x 2)
isbothPalin x = 
    isPalin (show x) && isPalin (toBase2 x)
problem_36= 
    sum $ filter isbothPalin $ filter (not.even) [1..1000000]

7 Problem 37

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

Solution:

-- isPrime in p35
clist n = 
    filter isLeftTruncatable $ if isPrime n then n:ns else []
    where
    ns = concatMap (clist . ((10*n) +)) [1,3,7,9]
 
isLeftTruncatable =
    all isPrime . map read . init . tail . tails . show
problem_37 =
    sum $ filter (>=10) $ concatMap clist [2,3,5,7]

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

takeLots :: [Int] -> [a] -> [a]
takeLots = 
    t 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