Personal tools

Euler problems/41 to 50

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 4: Line 4:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_41 = head [p | n <- init (tails "987654321"),
+
import Data.List
p <- perms n, isPrime (read p)]
+
isprime a = isprimehelper a primes
where
+
isprimehelper a (p:ps)
perms [] = [[]]
+
| a == 1 = False
perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)]
+
| p*p > a = True
isPrime n = n > 1 && smallestDivisor n == n
+
| a `mod` p == 0 = False
smallestDivisor n = findDivisor n (2:[3,5..])
+
| otherwise = isprimehelper a ps
findDivisor n (testDivisor:rest)
+
primes = 2 : filter isprime [3,5..]
| n `mod` testDivisor == 0 = testDivisor
+
problem_41 =
| testDivisor*testDivisor >= n = n
+
head.filter isprime.filter fun $ [7654321,7654320..]
| otherwise = findDivisor n rest
+
where
  +
fun =(=="1234567").sort.show
 
</haskell>
 
</haskell>
   
Line 23: Line 23:
 
<haskell>
 
<haskell>
 
import Data.Char
 
import Data.Char
score = sum . map ((subtract 64) . ord . toUpper)
+
trilist = takeWhile (<300) (scanl1 (+) [1..])
+
wordscore xs = sum $ map (subtract 64 . ord) xs
istrig n = istrig' n trigs
+
problem_42 megalist=
+
length [ wordscore a |
istrig' n (t:ts)
+
a <- megalist,
| n == t = True
+
elem (wordscore a) trilist
| 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
 
main=do
 
f<-readFile "words.txt"
 
f<-readFile "words.txt"
let words=tail$("":)$read $"["++f++"]"
+
let words=read $"["++f++"]"
 
print $problem_42 words
 
print $problem_42 words
 
 
</haskell>
 
</haskell>
   
Line 42: Line 41:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.List (inits, tails)
+
import Data.List
  +
l2n :: (Integral a) => [a] -> a
  +
l2n = foldl' (\a b -> 10*a+b) 0
 
 
perms [] = [[]]
+
swap (a,b) = (b,a)
perms (x:xs) =
 
[ p ++ [x] ++ s |
 
xs' <- perms xs ,
 
(p, s) <- zip (inits xs') (tails xs')
 
]
 
 
 
check n =
+
explode :: (Integral a) => a -> [a]
all (\x -> (read $ fst x) `mod` snd x == 0) $
+
explode =
zip (map (take 3) $ tail $ tails n)
+
unfoldr (\a -> if a==0 then Nothing else Just $ swap $ quotRem a 10)
[2,3,5,7,11,13,17]
+
problem_43 = sum . map l2n . map (\s -> head ([0..9] \\ s):s)
  +
. filter (elem 0) . genSeq [] $ [17,13,11,7,5,3,2]
  +
  +
mults mi ma n = takeWhile (< ma) $ dropWhile (<mi) $ iterate (+n) n
 
 
problem_43 = foldr (\x y -> read x + y) 0 $ filter check $ perms "0123456789"
+
sequ xs ys = tail xs == init ys
  +
  +
addZ n xs = replicate (n - length xs) 0 ++ xs
  +
  +
genSeq [] (x:xs) = genSeq
  +
(filter (not . doub)
  +
$ map (addZ 3 . reverse . explode) $ mults 9 1000 x)
  +
xs
  +
genSeq ys (x:xs) =
  +
genSeq (do
  +
m <- mults 9 1000 x
  +
let s = addZ 3 . reverse . explode $ m
  +
y <- filter (sequ s . take 3) $ filter (not . elem (head s)) ys
  +
return (head s:y)
  +
) xs
  +
genSeq ys [] = ys
  +
  +
doub xs = nub xs /= xs
 
</haskell>
 
</haskell>
   
Line 59: Line 58:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
combine xs = combine' [] xs
+
import Data.Set
where
 
combine' acc (x:xs) = map (\n -> (n, x)) acc ++ combine' (x:acc) xs
 
 
 
problem_44 =
 
problem_44 =
d $ head $ filter f $ combine [p n| n <- [1..]]
+
head solutions
where
+
where
f (a,b) = t (abs $ b-a) && t (a+b)
+
solutions =
d (a,b) = abs (a-b)
+
[a-b |
p n = n*(3*n-1) `div` 2
+
a <- penta,
t n = p (fromInteger(round((1+sqrt(24*fromInteger(n)+1))/6))) == n
+
b <- takeWhile (<a) penta,
  +
isPenta (a-b),
  +
isPenta (b+a)
  +
]
  +
isPenta = (`member` fromList penta)
  +
penta = [(n * (3*n-1)) `div` 2 | n <- [1..5000]]
 
</haskell>
 
</haskell>
   
Line 74: Line 73:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_45 = head . dropWhile (<= 40755) $ match tries (match pents hexes)
+
isPent n =
where match (x:xs) (y:ys)
+
(af == 0) && ai `mod` 6 == 5
| x < y = match xs (y:ys)
+
where
| y < x = match (x:xs) ys
+
(ai, af) = properFraction $ sqrt $ 1 + 24 * (fromInteger n)
| otherwise = x : match xs ys
+
tries = [n*(n+1) `div` 2 | n <- [1..]]
+
problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x]
pents = [n*(3*n-1) `div` 2 | n <- [1..]]
 
hexes = [n*(2*n-1) | n <- [1..]]
 
 
</haskell>
 
</haskell>
   
Line 88: Line 87:
   
 
This solution is inspired by exercise 3.70 in ''Structure and Interpretation of Computer Programs'', (2nd ed.).
 
This solution is inspired by exercise 3.70 in ''Structure and Interpretation of Computer Programs'', (2nd ed.).
 
<haskell>
 
problem_46 = head $ oddComposites `orderedDiff` gbSums
 
   
oddComposites = filter ((>1) . length . primeFactors) [3,5..]
+
millerRabinPrimality on the [[Prime_numbers]] page
   
gbSums = map gbWeight $ weightedPairs gbWeight primes [2*n*n | n <- [1..]]
+
<haskell>
gbWeight (a,b) = a + b
+
import Data.List
+
isPrime x
weightedPairs w (x:xs) (y:ys) =
+
|x==3=True
(x,y) : mergeWeighted w (map ((,)x) ys) (weightedPairs w xs (y:ys))
+
|otherwise=millerRabinPrimality x 2
+
problem_46 =
mergeWeighted w (x:xs) (y:ys)
+
find (\x -> not (isPrime x) && check x) [3,5..]
| w x <= w y = x : mergeWeighted w xs (y:ys)
+
where
| otherwise = y : mergeWeighted w (x:xs) ys
+
check x =
+
not $ any isPrime $takeWhile (>0) $ map (\y -> x - 2 * y * y) [1..]
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
 
 
</haskell>
 
</haskell>
   
Line 111: Line 107:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.List (group)
+
import Data.List
+
problem_47 = find (all ((==4).snd)) . map (take 4) . tails
factor_lengths :: [(Integer,Int)]
+
. zip [1..] . map (length . factors) $ [1..]
factor_lengths = [(n, length $ group $ primeFactors n)| n <- [2..]]
+
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
  +
fac [(x,y)]=[x^a|a<-[0..y]]
  +
fac (x:xs)=[a*b|a<-fac [x],b<-fac xs]
  +
factors x=fac$fstfac x
  +
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
   
problem_47 :: Integer
+
primeFactors n = factor n primes
problem_47 = f factor_lengths
 
 
where
 
where
f (a:b:c:d:xs)
+
factor _ [] = []
| 4 == snd a && snd a == snd b && snd b == snd c && snd c == snd d = fst a
+
factor m (p:ps) | p*p > m = [m]
| otherwise = f (b:c:d:xs)
+
| m `mod` p == 0 = p : [m `div` p]
  +
| otherwise = factor m ps
 
</haskell>
 
</haskell>
   
Line 128: Line 124:
 
Solution:
 
Solution:
 
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.
  +
  +
powMod on the [[Prime_numbers]] page
  +
 
<haskell>
 
<haskell>
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]]
 
problem_48 = flip mod limit$sum [powMod limit n n | n <- [1..1000]]
 
where
 
where
Line 155: Line 137:
   
 
Solution:
 
Solution:
  +
millerRabinPrimality on the [[Prime_numbers]] page
   
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. [[User:Jim Burton|Jim Burton]] 10:02, 9 July 2007 (UTC)
 
 
<haskell>
 
<haskell>
  +
import Control.Monad
 
import Data.List
 
import Data.List
isprime :: (Integral a) => a -> Bool
+
isPrime x
isprime n = isprime2 2
+
|x==3=True
where isprime2 x | x < n = if n `mod` x == 0 then False else isprime2 (x+1)
+
|otherwise=millerRabinPrimality x 2
| otherwise = True
 
 
 
  +
primes4 = takeWhile (<10000) $ dropWhile (<1000) primes
  +
  +
problem_49 = do
  +
a <- primes4
  +
b <- dropWhile (<= a) primes4
  +
guard ((sort $ show a) == (sort $ show b))
  +
let c = 2 * b - a
  +
guard (c < 10000)
  +
guard ((sort $ show a) == (sort $ show c))
  +
guard $ isPrime c
  +
return (a, b, c)
 
 
-- 'each' works like this: each (4,1234) => [1,2,3,4]
+
primes = 2 : filter (\x -> isPrime x ) [3..]
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))/=[]
 
]
 
 
 
</haskell>
 
</haskell>
   
Line 172: Line 164:
 
Which prime, below one-million, can be written as the sum of the most consecutive primes?
 
Which prime, below one-million, can be written as the sum of the most consecutive primes?
   
Solution: (prime and isPrime not included)
+
Solution:
  +
(prime and isPrime not included)
  +
 
<haskell>
 
<haskell>
  +
import Control.Monad
 
findPrimeSum ps
 
findPrimeSum ps
 
| isPrime sumps = Just sumps
 
| isPrime sumps = Just sumps

Revision as of 11:41, 17 January 2008

Contents

1 Problem 41

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

Solution:

import Data.List
isprime a = isprimehelper a primes
isprimehelper a (p:ps)
    | a == 1 = False
    | p*p > a = True
    | a `mod` p == 0 = False
    | otherwise = isprimehelper a ps
primes = 2 : filter isprime [3,5..]
problem_41 = 
    head.filter isprime.filter fun $ [7654321,7654320..]
    where
    fun =(=="1234567").sort.show

2 Problem 42

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

Solution:

import Data.Char
trilist = takeWhile (<300) (scanl1 (+) [1..])
wordscore xs = sum $ map (subtract 64 . ord) xs
problem_42 megalist= 
    length [ wordscore a |
    a <- megalist,
    elem (wordscore a) trilist
    ]
main=do
    f<-readFile "words.txt"
    let words=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
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)
problem_43 = sum . map l2n . map (\s -> head ([0..9] \\ s):s) 
                 . filter (elem 0) . genSeq [] $ [17,13,11,7,5,3,2]
 
mults mi ma n = takeWhile (< ma) $ dropWhile (<mi) $ iterate (+n) n
 
sequ xs ys = tail xs == init ys
 
addZ n xs = replicate (n - length xs) 0 ++ xs
 
genSeq [] (x:xs) = genSeq 
                   (filter (not . doub) 
                   $ map (addZ 3 . reverse . explode) $ mults 9 1000 x)
                   xs
genSeq ys (x:xs) = 
    genSeq (do
             m <- mults 9 1000 x
             let s = addZ 3 . reverse . explode $ m
             y <- filter (sequ s . take 3) $ filter (not . elem (head s)) ys
             return (head s:y)
           ) xs
genSeq ys [] = ys
 
doub xs = nub xs /= xs

4 Problem 44

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

Solution:

import Data.Set
problem_44 = 
    head solutions
    where 
    solutions = 
        [a-b |
        a <- penta,
        b <- takeWhile (<a) penta,
        isPenta (a-b),
        isPenta (b+a)
        ]
    isPenta = (`member` fromList  penta)
    penta = [(n * (3*n-1)) `div` 2 | n <- [1..5000]]

5 Problem 45

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

Solution:

isPent n = 
    (af == 0) && ai `mod` 6 == 5
    where
    (ai, af) = properFraction $ sqrt $ 1 + 24 * (fromInteger n)
 
problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x]

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

millerRabinPrimality on the Prime_numbers page

import Data.List
isPrime x
    |x==3=True
    |otherwise=millerRabinPrimality x 2
problem_46 = 
    find (\x -> not (isPrime x) && check x) [3,5..]
    where
    check x = 
        not $ any isPrime $takeWhile (>0) $ map (\y -> x - 2 * y * y) [1..]

7 Problem 47

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

Solution:

import Data.List
problem_47 = find (all ((==4).snd)) . map (take 4) . tails 
                 . zip [1..] . map (length . factors) $ [1..]
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
fac [(x,y)]=[x^a|a<-[0..y]]
fac (x:xs)=[a*b|a<-fac [x],b<-fac xs]
factors x=fac$fstfac x
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
 
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : [m `div` p]
                        | otherwise      = factor m ps

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.

powMod on the Prime_numbers page

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: millerRabinPrimality on the Prime_numbers page

import Control.Monad
import Data.List
isPrime x
    |x==3=True
    |otherwise=millerRabinPrimality x 2
 
primes4 = takeWhile (<10000) $ dropWhile (<1000) primes
 
problem_49 = do 
    a <- primes4
    b <- dropWhile (<= a) primes4
    guard ((sort $ show a) == (sort $ show b))
    let c = 2 * b - a
    guard (c < 10000)
    guard ((sort $ show a) == (sort $ show c))
    guard $ isPrime c 
    return (a, b, c)
 
primes = 2 : filter (\x -> isPrime x ) [3..]

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)

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