Euler problems/41 to 50
|Line 248:||Line 248:|
problem_48 = (`mod` limit) $ sum [powMod limit n n | n <- [1..1000]]
problem_48 = (`mod` limit) $ sum [powMod limit n n | n <- [1..1000]]
Revision as of 04:27, 8 April 2010
What is the largest n-digit pandigital prime that exists?
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
How many triangle words can you make using the list of common English words?
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
Find the sum of all pandigital numbers with an unusual sub-string divisibility property.
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
Find the smallest pair of pentagonal numbers whose sum and difference is pentagonal.
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]]
After 40755, what is the next triangle number that is also pentagonal and hexagonal?
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]
What is the smallest odd composite that cannot be written as the sum of a prime and twice a square?
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..]
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
Find the first four consecutive integers to have four distinct primes factors.
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
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 = (`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]
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