Difference between revisions of "Euler problems/41 to 50"
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 |
+ | where |
− | + | perms [] = [[]] |
|
+ | perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)] |
||
− | isPrime n = n > 1 && smallestDivisor n == n |
||
− | smallestDivisor n = |
+ | 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 |
||
</haskell> |
</haskell> |
||
Line 21: | Line 22: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.Char |
||
− | score :: String -> Int |
||
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' : |
+ | 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..] |
trigs = map (\n -> n*(n+1) `div` 2) [1..] |
||
+ | |||
− | --get ws from the Euler site |
||
⚫ | |||
− | ws = ["A","ABILITY" ... "YOURSELF","YOUTH"] |
||
+ | |||
+ | main=do |
||
+ | f<-readFile "words.txt" |
||
+ | let words=tail$("":)$read $"["++f++"]" |
||
+ | print $problem_42 words |
||
⚫ | |||
</haskell> |
</haskell> |
||
Line 44: | Line 50: | ||
<haskell> |
<haskell> |
||
import Data.List (inits, tails) |
import Data.List (inits, tails) |
||
+ | |||
− | |||
− | perms :: [a] -> [[a]] |
||
perms [] = [[]] |
perms [] = [[]] |
||
− | perms (x:xs) = |
+ | perms (x:xs) = |
+ | [ p ++ [x] ++ s | |
||
⚫ | |||
+ | xs' <- perms xs , |
||
− | |||
⚫ | |||
− | check :: String -> Bool |
||
+ | ] |
||
⚫ | |||
+ | |||
− | |||
+ | check n = |
||
− | problem_43 :: Integer |
||
⚫ | |||
+ | 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 64: | Line 73: | ||
combine xs = combine' [] xs |
combine xs = combine' [] xs |
||
where |
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..]] |
||
where |
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 |
|
</haskell> |
</haskell> |
||
Line 143: | Line 153: | ||
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> |
||
+ | 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) |
||
⚫ | |||
+ | where |
||
+ | limit=10^10 |
||
</haskell> |
</haskell> |
||
Line 177: | Line 206: | ||
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' |
||
⚫ | |||
⚫ | |||
+ | res' = if pr `isin` res |
||
+ | then res |
||
⚫ | |||
p49a :: [[Int]] |
p49a :: [[Int]] |
||
Line 189: | Line 221: | ||
eqvList x y =[a|a<-x,b<-y,a==b] |
eqvList x y =[a|a<-x,b<-y,a==b] |
||
+ | problem_49 =[y| |
||
− | 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))/=[]] |
||
+ | 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 198: | Line 237: | ||
Solution: (prime and isPrime not included) |
Solution: (prime and isPrime not included) |
||
<haskell> |
<haskell> |
||
− | findPrimeSum ps |
+ | findPrimeSum ps |
+ | | isPrime sumps = Just sumps |
||
− | + | | 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
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
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
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"
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
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..]]
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
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)
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
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))/=[]
]
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