Difference between revisions of "Euler problems/41 to 50"
m 
(→Problem 41: It's tiring to see code which has been hacked together after the solution has been found to optimize it. e.g. Why was there the assumption that it was a 7digit pandigital?) 

Line 4:  Line 4:  
Solution: 
Solution: 

<haskell> 
<haskell> 

⚫  
+   Assuming isPrime has been implemented 

−  isprime a = isprimehelper a primes 

⚫  
−  isprimehelper a (p:ps) 

+  problem_41 = maximum [ n'  d < [3..9], n < permute ['1'..intToDigit d], 

−  +  let n' = read n, isPrime n'] 

−   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 
where 

−  fun = (=="1234567") . sort . show 

+  permute "" = [""] 

+  permute str = [(x:xs) x < str, xs < permute (delete x str)] 

</haskell> 
</haskell> 

Revision as of 12:12, 26 June 2011
Contents
Problem 41
What is the largest ndigit pandigital prime that exists?
Solution:
 Assuming isPrime has been implemented
import Data.Char (intToDigit)
problem_41 = maximum [ n'  d < [3..9], n < permute ['1'..intToDigit d],
let n' = read n, isPrime n']
where
permute "" = [""]
permute str = [(x:xs) x < str, xs < permute (delete x str)]
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 substring 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 (notElem (head s)) ys
return (head s:y))
xs
genSeq ys [] = ys
doub xs = nub xs /= xs
An arguably cleaner, alternate solution uses nondeterminism + state to create a backtracking monad particularly suited to this problem:
import Control.Monad
import Control.Monad.State
import Data.Set
type Select elem a = StateT (Set elem) [] a
select :: (Ord elem) => [elem] > Select elem elem
select as = do
set < get
a < lift as
guard (not (member a set))
put (insert a set)
return a
runSelect :: Select elem a > [a]
runSelect m = Prelude.map fst (runStateT m empty)
fromDigits = foldl (\tot d > 10 * tot + d) 0
ds = runSelect $ do
d4 < select [0,2..8]
d3 < select [0..9]
d5 < select [0..9]
guard ((d3 + d4 + d5) `mod` 3 == 0)
d6 < select [0,5]
d7 < select [0..9]
guard ((100 * d5 + 10 * d6 + d7) `mod` 7 == 0)
d8 < select [0..9]
guard ((d6  d7 + d8) `mod` 11 == 0)
d9 < select [0..9]
guard ((100 * d7 + 10 * d8 + d9) `mod` 13 == 0)
d10 < select [0..9]
guard ((100 * d8 + 10 * d9 + d10) `mod` 17 == 0)
d2 < select [0..9]
d1 < select [0..9]
return (fromDigits [d1, d2, d3, d4, d5, d6, d7, d8, d9, d10])
answer = sum ds
main = do
print ds
print answer
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 = [ab  a < penta,
b < takeWhile (<a) penta,
isPenta (ab),
isPenta (b+a) ]
isPenta = (`member` fromList penta)
penta = [(n * (3*n1)) `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..]
Alternate Solution:
Considering that the answer is less than 6000, there's no need for fancy solutions. The following is as fast as most C++ solutions.
primes :: [Int]
primes = 2 : filter isPrime [3, 5..]
isPrime :: Int > Bool
isPrime n = all (not . divides n) $ takeWhile (\p > p^2 <= n) primes
where
divides n p = n `mod` p == 0
compOdds :: [Int]
compOdds = filter (not . isPrime) [3, 5..]
verifConj :: Int > Bool
verifConj n = any isPrime (takeWhile (>0) $ map (\i > n  2*i*i) [1..])
problem_46 :: Int
problem_46 = head $ filter (not . verifConj) compOdds
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
Alternate Solution:
The previous solution actually didn't give the correct answer for me. The following method did.
import Data.List
import Data.Numbers
import Data.Numbers.Primes
import qualified Data.Set as Set
dPrimeFactors n = Set.fromList $ primeFactors n
dPFList n = [(k, dPrimeFactors k)  k < filter (\z > (not $ isPrime z)) [1..n]]
nConsec n s =
let dpf = dPFList s
fltrd = filter (\z > Set.size (snd z) == n) dpf
gps = [take (fromIntegral n) (drop (fromIntegral k) fltrd)  k < [0..(length fltrd  n)] ]
gps2 = filter (\z > isConsec (map fst z)) gps
in filter (\zz > Set.empty == foldl (\acc z > Set.intersection acc (snd z)) (snd (head zz)) zz) gps2
isConsec xs = (sort xs) == [(minimum xs)..(maximum xs)]
problem_47 = (fst . head . head) $ nConsec 4 20000
Problem 48
Find the last ten digits of 1^{1} + 2^{2} + ... + 1000^{1000}.
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 = (`mod` limit) $ sum [powMod limit n n  n < [1..1000]]
where limit=10^10
Another oneliner for this problem, with no use of other functions is the following:
problem_48 = reverse $ take 10 $ reverse $ show $ sum $ map (\x > x^x) [1..1000]
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 Data.List
isPrime x
 x==3 = True
 otherwise = millerRabinPrimality x 2
primes4 = filter isPrime [1000..9999]
problem_49 = [ (a,b,c)  a < primes4,
b < dropWhile (<= a) primes4,
sort (show a) == sort (show b),
let c = 2 * b  a,
c `elem` primes4,
sort (show a) == sort (show c) ]
Problem 50
Which prime, below onemillion, 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