Personal tools

Euler problems/41 to 50

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 6: Line 6:
 
problem_41 = head [p | n <- init (tails "987654321"),
 
problem_41 = head [p | n <- init (tails "987654321"),
 
p <- perms n, isPrime (read p)]
 
p <- perms n, isPrime (read p)]
where perms [] = [[]]
+
where
perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)]
+
perms [] = [[]]
isPrime n = n > 1 && smallestDivisor n == n
+
perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)]
smallestDivisor n = findDivisor n (2:[3,5..])
+
isPrime n = n > 1 && smallestDivisor n == n
findDivisor n (testDivisor:rest)
+
smallestDivisor n = findDivisor n (2:[3,5..])
| n `mod` testDivisor == 0 = testDivisor
+
findDivisor n (testDivisor:rest)
| testDivisor*testDivisor >= n = n
+
| n `mod` testDivisor == 0 = testDivisor
| otherwise = findDivisor n rest
+
| testDivisor*testDivisor >= n = n
  +
| otherwise = findDivisor n rest
 
</haskell>
 
</haskell>
   
Line 21: Line 21:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
score :: String -> Int
+
import Data.Char
 
score = sum . map ((subtract 64) . ord . toUpper)
 
score = sum . map ((subtract 64) . ord . toUpper)
+
istrig :: Int -> Bool
 
 
istrig n = istrig' n trigs
 
istrig n = istrig' n trigs
+
istrig' :: Int -> [Int] -> Bool
+
istrig' n (t:ts)
istrig' n (t:ts) | n == t = True
+
| n == t = True
| otherwise = if t < n && head ts > n then False else istrig' n ts
+
| otherwise = if t < n && head ts > n
+
then False
  +
else istrig' n ts
  +
 
trigs = map (\n -> n*(n+1) `div` 2) [1..]
 
trigs = map (\n -> n*(n+1) `div` 2) [1..]
--get ws from the Euler site
+
ws = ["A","ABILITY" ... "YOURSELF","YOUTH"]
+
problem_42 ws= length $ filter id $ map (istrig . score) ws
  +
  +
main=do
  +
f<-readFile "words.txt"
  +
let words=tail$("":)$read $"["++f++"]"
  +
print $problem_42 words
   
problem_42 = length $ filter id $ map (istrig . score) ws
 
 
</haskell>
 
</haskell>
   
Line 43: Line 42:
 
<haskell>
 
<haskell>
 
import Data.List (inits, tails)
 
import Data.List (inits, tails)
+
perms :: [a] -> [[a]]
 
 
perms [] = [[]]
 
perms [] = [[]]
perms (x:xs) = [ p ++ [x] ++ s | xs' <- perms xs
+
perms (x:xs) =
, (p, s) <- zip (inits xs') (tails xs') ]
+
[ p ++ [x] ++ s |
+
xs' <- perms xs ,
check :: String -> Bool
+
(p, s) <- zip (inits xs') (tails xs')
check n = all (\x -> (read $ fst x) `mod` snd x == 0) $ zip (map (take 3) $ tail $ tails n) [2,3,5,7,11,13,17]
+
]
+
problem_43 :: Integer
+
check n =
  +
all (\x -> (read $ fst x) `mod` snd x == 0) $
  +
zip (map (take 3) $ tail $ tails n)
  +
[2,3,5,7,11,13,17]
  +
 
problem_43 = foldr (\x y -> read x + y) 0 $ filter check $ perms "0123456789"
 
problem_43 = foldr (\x y -> read x + y) 0 $ filter check $ perms "0123456789"
 
</haskell>
 
</haskell>
Line 62: Line 61:
 
combine xs = combine' [] xs
 
combine xs = combine' [] xs
 
where
 
where
combine' acc (x:xs) = map (\n -> (n, x)) acc ++ combine' (x:acc) xs
+
combine' acc (x:xs) = map (\n -> (n, x)) acc ++ combine' (x:acc) xs
   
problem_44 = d $ head $ filter f $ combine [p n| n <- [1..]]
+
problem_44 =
  +
d $ head $ filter f $ combine [p n| n <- [1..]]
 
where
 
where
f (a,b) = t (abs $ b-a) && t (a+b)
+
f (a,b) = t (abs $ b-a) && t (a+b)
d (a,b) = abs (a-b)
+
d (a,b) = abs (a-b)
p n = n*(3*n-1) `div` 2
+
p n = n*(3*n-1) `div` 2
t n = p (fromInteger(round((1+sqrt(24*fromInteger(n)+1))/6))) == n
+
t n = p (fromInteger(round((1+sqrt(24*fromInteger(n)+1))/6))) == n
 
</haskell>
 
</haskell>
   
Line 141: Line 140:
 
If the problem were more computationally intensive, [http://en.wikipedia.org/wiki/Modular_exponentiation modular exponentiation] might be appropriate. With this problem size the naive approach is sufficient.
 
If the problem were more computationally intensive, [http://en.wikipedia.org/wiki/Modular_exponentiation modular exponentiation] might be appropriate. With this problem size the naive approach is sufficient.
 
<haskell>
 
<haskell>
problem_48 = sum [n^n | n <- [1..1000]] `mod` 10^10
+
mulMod :: Integral a => a -> a -> a -> a
  +
mulMod a b c= (b * c) `rem` a
  +
squareMod :: Integral a => a -> a -> a
  +
squareMod a b = (b * b) `rem` a
  +
pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a
  +
pow' _ _ _ 0 = 1
  +
pow' mul sq x' n' = f x' n' 1
  +
where
  +
f x n y
  +
| n == 1 = x `mul` y
  +
| r == 0 = f x2 q y
  +
| otherwise = f x2 q (x `mul` y)
  +
where
  +
(q,r) = quotRem n 2
  +
x2 = sq x
  +
powMod :: Integral a => a -> a -> a -> a
  +
powMod m = pow' (mulMod m) (squareMod m)
  +
problem_48 = flip mod limit$sum [powMod limit n n | n <- [1..1000]]
  +
where
  +
limit=10^10
 
</haskell>
 
</haskell>
   
Line 175: Line 174:
 
problem_49_1 [] res = res
 
problem_49_1 [] res = res
 
problem_49_1 (pr:prims) res = problem_49_1 prims res'
 
problem_49_1 (pr:prims) res = problem_49_1 prims res'
where res' = if pr `isin` res then res else res ++ [pr:(filter (ispermut pr) (pr:prims))]
+
where
  +
res' = if pr `isin` res
  +
then res
  +
else res ++ [pr:(filter (ispermut pr) (pr:prims))]
 
 
 
p49a :: [[Int]]
 
p49a :: [[Int]]
Line 187: Line 186:
 
eqvList x y =[a|a<-x,b<-y,a==b]
 
eqvList x y =[a|a<-x,b<-y,a==b]
   
problem_49 =[y|x<-p49a,let y=sort$nub x,length(y)>=4,let z=unAdd y,length(z)/=length(nub z),(eqvList (div2un y) (takeEqv z))/=[]]
+
problem_49 =[y|
  +
x<-p49a,
  +
let y=sort$nub x,
  +
length(y)>=4,
  +
let z=unAdd y,
  +
length(z)/=length(nub z),
  +
(eqvList (div2un y) (takeEqv z))/=[]
  +
]
   
 
</haskell>
 
</haskell>
Line 196: Line 195:
 
Solution: (prime and isPrime not included)
 
Solution: (prime and isPrime not included)
 
<haskell>
 
<haskell>
findPrimeSum ps | isPrime sumps = Just sumps
+
findPrimeSum ps
| otherwise = findPrimeSum (tail ps) `mplus` findPrimeSum (init ps)
+
| isPrime sumps = Just sumps
where sumps = sum ps
+
| otherwise = findPrimeSum (tail ps) `mplus` findPrimeSum (init ps)
  +
where
  +
sumps = sum ps
   
 
problem_50 = findPrimeSum $ take 546 primes
 
problem_50 = findPrimeSum $ take 546 primes

Revision as of 03:10, 6 January 2008

Contents

1 Problem 41

What is the largest n-digit pandigital prime that exists?

Solution:

problem_41 = head [p | n <- init (tails "987654321"),
                   p <- perms n, isPrime (read p)]
    where 
    perms [] = [[]]
    perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)]
    isPrime n = n > 1 && smallestDivisor n == n
    smallestDivisor n = findDivisor n (2:[3,5..])
    findDivisor n (testDivisor:rest)
        | n `mod` testDivisor == 0      = testDivisor
        | testDivisor*testDivisor >= n  = n
        | otherwise                     = findDivisor n rest

2 Problem 42

How many triangle words can you make using the list of common English words?

Solution:

import Data.Char
score = sum . map ((subtract 64) . ord . toUpper)
 
istrig n = istrig' n trigs
 
istrig' n (t:ts) 
    | n == t    = True
    | otherwise = if t < n && head ts > n 
                  then False 
                  else  istrig' n ts
 
trigs = map (\n -> n*(n+1) `div` 2) [1..]
 
problem_42 ws= length $ filter id $ map (istrig . score) ws
 
main=do
    f<-readFile "words.txt"
    let words=tail$("":)$read $"["++f++"]"
    print $problem_42 words

3 Problem 43

Find the sum of all pandigital numbers with an unusual sub-string divisibility property.

Solution:

import Data.List (inits, tails)
 
perms [] = [[]]
perms (x:xs) = 
    [ p ++ [x] ++ s |
    xs' <- perms xs ,
    (p, s) <- zip (inits xs') (tails xs')
    ]
 
check n = 
    all (\x -> (read $ fst x) `mod` snd x == 0) $
    zip (map (take 3) $ tail $ tails n) 
    [2,3,5,7,11,13,17]
 
problem_43 = foldr (\x y -> read x + y) 0 $ filter check $ perms "0123456789"

4 Problem 44

Find the smallest pair of pentagonal numbers whose sum and difference is pentagonal.

Solution:

combine xs = combine' [] xs
    where
    combine' acc (x:xs) = map (\n -> (n, x)) acc ++ combine' (x:acc) xs
 
problem_44 = 
    d $ head $ filter f $ combine [p n| n <- [1..]]
    where
    f (a,b) = t (abs $ b-a) && t (a+b)
    d (a,b) = abs (a-b)
    p n = n*(3*n-1) `div` 2
    t n = p (fromInteger(round((1+sqrt(24*fromInteger(n)+1))/6))) == n

5 Problem 45

After 40755, what is the next triangle number that is also pentagonal and hexagonal?

Solution:

problem_45 =  head . dropWhile (<= 40755) $ match tries (match pents hexes)
    where match (x:xs) (y:ys)
              | x < y  = match xs (y:ys)
              | y < x  = match (x:xs) ys
              | otherwise = x : match xs ys
          tries = [n*(n+1) `div` 2   | n <- [1..]]
          pents = [n*(3*n-1) `div` 2 | n <- [1..]]
          hexes = [n*(2*n-1)         | n <- [1..]]

6 Problem 46

What is the smallest odd composite that cannot be written as the sum of a prime and twice a square?

Solution:

This solution is inspired by exercise 3.70 in Structure and Interpretation of Computer Programs, (2nd ed.).

problem_46 = head $ oddComposites `orderedDiff` gbSums
 
oddComposites = filter ((>1) . length . primeFactors) [3,5..]
 
gbSums = map gbWeight $ weightedPairs gbWeight primes [2*n*n | n <- [1..]]
gbWeight (a,b) = a + b
 
weightedPairs w (x:xs) (y:ys) =
    (x,y) : mergeWeighted w (map ((,)x) ys) (weightedPairs w xs (y:ys))
 
mergeWeighted w (x:xs)  (y:ys)
    | w x <= w y  = x : mergeWeighted w xs (y:ys)
    | otherwise   = y : mergeWeighted w (x:xs) ys
 
x `orderedDiff` [] = x
[] `orderedDiff` y = []
(x:xs) `orderedDiff` (y:ys)
    | x < y     = x : xs `orderedDiff` (y:ys)
    | x > y     = (x:xs) `orderedDiff` ys
    | otherwise = xs `orderedDiff` ys

7 Problem 47

Find the first four consecutive integers to have four distinct primes factors.

Solution:

import Data.List (group)
 
factor_lengths :: [(Integer,Int)]
factor_lengths = [(n, length $ group $ primeFactors n)| n <- [2..]]
 
problem_47 :: Integer
problem_47 = f factor_lengths
    where
        f (a:b:c:d:xs)
            | 4 == snd a && snd a == snd b && snd b == snd c && snd c == snd d = fst a
            | otherwise = f (b:c:d:xs)

8 Problem 48

Find the last ten digits of 11 + 22 + ... + 10001000.

Solution: If the problem were more computationally intensive, modular exponentiation might be appropriate. With this problem size the naive approach is sufficient.

mulMod :: Integral a => a -> a -> a -> a
mulMod a b c= (b * c) `rem` a
squareMod :: Integral a => a -> a -> a
squareMod a b = (b * b) `rem` a
pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a
pow' _ _ _ 0 = 1
pow' mul sq x' n' = f x' n' 1
    where
    f x n y
        | n == 1 = x `mul` y
        | r == 0 = f x2 q y
        | otherwise = f x2 q (x `mul` y)
        where
            (q,r) = quotRem n 2
            x2 = sq x
powMod :: Integral a => a -> a -> a -> a
powMod m = pow' (mulMod m) (squareMod m)
problem_48 = flip mod limit$sum [powMod limit n n | n <- [1..1000]]
    where
    limit=10^10

9 Problem 49

Find arithmetic sequences, made of prime terms, whose four digits are permutations of each other.

Solution:

I'm new to haskell, improve here :-)

I tidied up your solution a bit, mostly by using and composing library functions where possible...makes it faster on my system. Jim Burton 10:02, 9 July 2007 (UTC)

import Data.List
isprime :: (Integral a) => a -> Bool
isprime n = isprime2 2
    where isprime2 x | x < n     = if n `mod` x == 0 then False else isprime2 (x+1)
                     | otherwise = True
 
 
-- 'each' works like this: each (4,1234) => [1,2,3,4]
each :: (Int, Int) -> [Int]
each = unfoldr (\(o,y) -> let x = 10 ^ (o-1) 
                              (d,m) = y `divMod` x in
                          if o == 0 then Nothing else Just (d,(o-1,m)))
 
ispermut :: Int -> Int -> Bool
ispermut = let f = (sort . each . (,) 4) in (. f) . (==) . f
 
isin :: (Eq a) => a -> [[a]] -> Bool
isin = any . elem 
 
problem_49_1 :: [Int] -> [[Int]] -> [[Int]]
problem_49_1 [] res = res
problem_49_1 (pr:prims) res = problem_49_1 prims res'
    where 
    res' = if pr `isin` res 
           then res 
           else res ++ [pr:(filter (ispermut pr) (pr:prims))]
 
p49a :: [[Int]]
p49a = problem_49_1 [n | n <- [1000..9999], isprime n] []
unAdd []=[]
unAdd (x:xs)=[x-y|y<-xs]++(unAdd xs)
takeEqv []=[]
takeEqv (x:xs)=[x|y<-xs,x-y==0]++(takeEqv xs)
div2un []=[]
div2un (x:xs)=[div (x-y) 2|y<-xs]++(div2un xs)
eqvList x y =[a|a<-x,b<-y,a==b]
 
problem_49 =[y|
    x<-p49a,
    let y=sort$nub x,
    length(y)>=4,
    let z=unAdd y,
    length(z)/=length(nub z),
    (eqvList (div2un y) (takeEqv z))/=[]
    ]

10 Problem 50

Which prime, below one-million, can be written as the sum of the most consecutive primes?

Solution: (prime and isPrime not included)

findPrimeSum ps 
    | isPrime sumps = Just sumps
    | otherwise     = findPrimeSum (tail ps) `mplus` findPrimeSum (init ps)
    where
    sumps = sum ps
 
problem_50 = findPrimeSum $ take 546 primes