# Euler problems/41 to 50

### From HaskellWiki

(→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 7-digit pandigital?) |
(→Problem 43: Both other solutions take >20 seconds. This takes <0.1 seconds..) |
||

Line 112: | Line 112: | ||

print ds |
print ds |
||

print answer |
print answer |
||

+ | </haskell> |
||

+ | |||

+ | An almost instant answer can be generated by only creating permutations which fulfil the requirement of particular digits being multiples of certain numbers. |
||

+ | |||

+ | <haskell> |
||

+ | import Data.List ((\\), nub) |
||

+ | |||

+ | main = print q43 |
||

+ | |||

+ | q43 = sum [ read n | (d7d8d9, remDigits) <- permMults digits 17, |
||

+ | (d4d5d6, remDigits') <- permMults remDigits 7, |
||

+ | d4d5d6 !! 1 == '0' || d4d5d6 !! 1 == '5', |
||

+ | (d1d2d3, remDigit) <- permMults remDigits' 2, |
||

+ | let n = remDigit ++ d1d2d3 ++ d4d5d6 ++ d7d8d9, |
||

+ | hasProperty (tail n) primes] |
||

+ | where |
||

+ | digits = "0123456789" |
||

+ | primes = [2,3,5,7,11,13,17] |
||

+ | hasProperty _ [] = True |
||

+ | hasProperty c (p:ps) = (read $ take 3 c) `mod` p == 0 && hasProperty (tail c) ps |
||

+ | permMults cs p = [ (ds, cs \\ ds) | n <- [p,2*p..987], |
||

+ | let ds = leadingZero n, |
||

+ | ds == nub ds, |
||

+ | all (flip elem cs) ds] |
||

+ | where |
||

+ | leadingZero n |
||

+ | | n < 10 = "00" ++ show n |
||

+ | | n < 100 = "0" ++ show n |
||

+ | | otherwise = show n |
||

</haskell> |
</haskell> |
||

## Revision as of 03:31, 27 June 2011

## Contents |

## 1 Problem 41

What is the largest n-digit 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)]

## 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 (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

An almost instant answer can be generated by only creating permutations which fulfil the requirement of particular digits being multiples of certain numbers.

import Data.List ((\\), nub) main = print q43 q43 = sum [ read n | (d7d8d9, remDigits) <- permMults digits 17, (d4d5d6, remDigits') <- permMults remDigits 7, d4d5d6 !! 1 == '0' || d4d5d6 !! 1 == '5', (d1d2d3, remDigit) <- permMults remDigits' 2, let n = remDigit ++ d1d2d3 ++ d4d5d6 ++ d7d8d9, hasProperty (tail n) primes] where digits = "0123456789" primes = [2,3,5,7,11,13,17] hasProperty _ [] = True hasProperty c (p:ps) = (read $ take 3 c) `mod` p == 0 && hasProperty (tail c) ps permMults cs p = [ (ds, cs \\ ds) | n <- [p,2*p..987], let ds = leadingZero n, ds == nub ds, all (flip elem cs) ds] where leadingZero n | n < 10 = "00" ++ show n | n < 100 = "0" ++ show n | otherwise = show n

## 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..]

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

## 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

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

## 8 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 one-liner 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]

## 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 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) ]

## 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