Difference between revisions of "Euler problems/41 to 50"
Line 4: | Line 4: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.List |
||
− | problem_41 = head [p | n <- init (tails "987654321"), |
||
+ | isprime a = isprimehelper a primes |
||
− | p <- perms n, isPrime (read p)] |
||
+ | isprimehelper a (p:ps) |
||
− | where |
||
− | + | | a == 1 = False |
|
+ | | p*p > a = True |
||
− | perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)] |
||
− | + | | a `mod` p == 0 = False |
|
+ | | otherwise = isprimehelper a ps |
||
− | smallestDivisor n = findDivisor n (2:[3,5..]) |
||
+ | primes = 2 : filter isprime [3,5..] |
||
− | findDivisor n (testDivisor:rest) |
||
+ | problem_41 = |
||
− | | n `mod` testDivisor == 0 = testDivisor |
||
+ | head.filter isprime.filter fun $ [7654321,7654320..] |
||
− | | testDivisor*testDivisor >= n = n |
||
+ | where |
||
− | | otherwise = findDivisor n rest |
||
+ | fun =(=="1234567").sort.show |
||
</haskell> |
</haskell> |
||
Line 23: | Line 24: | ||
<haskell> |
<haskell> |
||
import Data.Char |
import Data.Char |
||
+ | trilist = takeWhile (<300) (scanl1 (+) [1..]) |
||
− | score = sum . map ((subtract 64) . ord . toUpper) |
||
+ | wordscore xs = sum $ map (subtract 64 . ord) xs |
||
− | |||
+ | problem_42 megalist= |
||
− | istrig n = istrig' n trigs |
||
+ | length [ wordscore a | |
||
− | |||
+ | a <- megalist, |
||
− | istrig' n (t:ts) |
||
− | + | 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= |
+ | let words=read $"["++f++"]" |
print $problem_42 words |
print $problem_42 words |
||
− | |||
</haskell> |
</haskell> |
||
Line 49: | Line 42: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
− | import Data.List |
+ | import Data.List |
+ | l2n :: (Integral a) => [a] -> a |
||
+ | l2n = foldl' (\a b -> 10*a+b) 0 |
||
− | + | swap (a,b) = (b,a) |
|
− | perms (x:xs) = |
||
− | [ p ++ [x] ++ s | |
||
− | xs' <- perms xs , |
||
− | (p, s) <- zip (inits xs') (tails xs') |
||
− | ] |
||
+ | explode :: (Integral a) => a -> [a] |
||
− | check n = |
||
+ | explode = |
||
− | all (\x -> (read $ fst x) `mod` snd x == 0) $ |
||
− | + | 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) |
||
− | [2,3,5,7,11,13,17] |
||
+ | . 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 |
||
− | problem_43 = foldr (\x y -> read x + y) 0 $ filter check $ perms "0123456789" |
||
+ | |||
+ | 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 71: | Line 81: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.Set |
||
− | combine xs = combine' [] xs |
||
− | where |
||
− | combine' acc (x:xs) = map (\n -> (n, x)) acc ++ combine' (x:acc) xs |
||
− | |||
problem_44 = |
problem_44 = |
||
+ | head solutions |
||
− | d $ head $ filter f $ combine [p n| n <- [1..]] |
||
− | where |
+ | where |
+ | solutions = |
||
− | f (a,b) = t (abs $ b-a) && t (a+b) |
||
− | + | [a-b | |
|
− | + | a <- penta, |
|
+ | b <- takeWhile (<a) penta, |
||
− | t n = p (fromInteger(round((1+sqrt(24*fromInteger(n)+1))/6))) == n |
||
+ | isPenta (a-b), |
||
+ | isPenta (b+a) |
||
+ | ] |
||
+ | isPenta = (`member` fromList penta) |
||
+ | penta = [(n * (3*n-1)) `div` 2 | n <- [1..5000]] |
||
</haskell> |
</haskell> |
||
Line 89: | Line 101: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | isPent n = |
||
− | problem_45 = head . dropWhile (<= 40755) $ match tries (match pents hexes) |
||
+ | (af == 0) && ai `mod` 6 == 5 |
||
− | where match (x:xs) (y:ys) |
||
+ | where |
||
− | | x < y = match xs (y:ys) |
||
− | + | (ai, af) = properFraction $ sqrt $ 1 + 24 * (fromInteger n) |
|
+ | |||
− | | otherwise = x : match xs ys |
||
+ | problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x] |
||
− | tries = [n*(n+1) `div` 2 | n <- [1..]] |
||
− | pents = [n*(3*n-1) `div` 2 | n <- [1..]] |
||
− | hexes = [n*(2*n-1) | n <- [1..]] |
||
</haskell> |
</haskell> |
||
Line 105: | Line 115: | ||
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 |
||
+ | millerRabinPrimality on the [[Prime_numbers]] page |
||
− | oddComposites = filter ((>1) . length . primeFactors) [3,5..] |
||
+ | <haskell> |
||
− | gbSums = map gbWeight $ weightedPairs gbWeight primes [2*n*n | n <- [1..]] |
||
+ | import Data.List |
||
− | gbWeight (a,b) = a + b |
||
+ | isPrime x |
||
− | |||
+ | |x==3=True |
||
− | weightedPairs w (x:xs) (y:ys) = |
||
+ | |otherwise=millerRabinPrimality x 2 |
||
− | (x,y) : mergeWeighted w (map ((,)x) ys) (weightedPairs w xs (y:ys)) |
||
+ | problem_46 = |
||
− | |||
+ | find (\x -> not (isPrime x) && check x) [3,5..] |
||
− | mergeWeighted w (x:xs) (y:ys) |
||
+ | where |
||
− | | w x <= w y = x : mergeWeighted w xs (y:ys) |
||
+ | check x = |
||
− | | otherwise = y : mergeWeighted w (x:xs) ys |
||
+ | 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 134: | Line 135: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
− | import Data.List |
+ | import Data.List |
+ | problem_47 = find (all ((==4).snd)) . map (take 4) . tails |
||
− | |||
+ | . zip [1..] . map (length . factors) $ [1..] |
||
− | factor_lengths :: [(Integer,Int)] |
||
− | + | 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 |
||
− | problem_47 :: Integer |
||
− | problem_47 = f factor_lengths |
||
where |
where |
||
− | + | factor _ [] = [] |
|
− | + | factor m (p:ps) | p*p > m = [m] |
|
− | | |
+ | | m `mod` p == 0 = p : [m `div` p] |
+ | | otherwise = factor m ps |
||
</haskell> |
</haskell> |
||
Line 152: | Line 157: | ||
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 179: | Line 170: | ||
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 x |
||
− | isprime :: (Integral a) => a -> Bool |
||
+ | |x==3=True |
||
− | isprime n = isprime2 2 |
||
+ | |otherwise=millerRabinPrimality x 2 |
||
− | where isprime2 x | x < n = if n `mod` x == 0 then False else isprime2 (x+1) |
||
− | | 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) |
||
+ | primes = 2 : filter (\x -> isPrime x ) [3..] |
||
− | -- '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))/=[] |
||
− | ] |
||
− | |||
</haskell> |
</haskell> |
||
Line 235: | Line 197: | ||
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: |
+ | 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
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
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
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
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]]
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]
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..]
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
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
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..]
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