Personal tools

Euler problems/41 to 50

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 4: Line 4:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_41 = head [p | n <- init (tails "987654321"),
+
import Data.List
                  p <- perms n, isPrime (read p)]
+
isprime a = isprimehelper a primes
     where
+
isprimehelper a (p:ps)
     perms [] = [[]]
+
     | a == 1 = False
     perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)]
+
     | p*p > a = True
    isPrime n = n > 1 && smallestDivisor n == n
+
     | a `mod` p == 0 = False
     smallestDivisor n = findDivisor n (2:[3,5..])
+
     | otherwise = isprimehelper a ps
     findDivisor n (testDivisor:rest)
+
primes = 2 : filter isprime [3,5..]
        | n `mod` testDivisor == 0      = testDivisor
+
problem_41 =
        | testDivisor*testDivisor >= = n
+
     head.filter isprime.filter fun $ [7654321,7654320..]
        | otherwise                    = findDivisor n rest
+
    where
 +
    fun =(=="1234567").sort.show
 
</haskell>
 
</haskell>
  
Line 23: Line 24:
 
<haskell>
 
<haskell>
 
import Data.Char
 
import Data.Char
score = sum . map ((subtract 64) . ord . toUpper)
+
trilist = takeWhile (<300) (scanl1 (+) [1..])
+
wordscore xs = sum $ map (subtract 64 . ord) xs
istrig n = istrig' n trigs
+
problem_42 megalist=  
+
     length [ wordscore a |
istrig' n (t:ts)
+
     a <- megalist,
     | n == t    = True
+
    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=tail$("":)$read $"["++f++"]"
+
     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 (inits, tails)
+
import Data.List
 +
l2n :: (Integral a) => [a] -> a
 +
l2n = foldl' (\a b -> 10*a+b) 0
 
   
 
   
perms [] = [[]]
+
swap (a,b) = (b,a)
perms (x:xs) =  
+
    [ p ++ [x] ++ s |
+
    xs' <- perms xs ,
+
    (p, s) <- zip (inits xs') (tails xs')
+
    ]
+
 
   
 
   
check n =  
+
explode :: (Integral a) => a -> [a]
     all (\x -> (read $ fst x) `mod` snd x == 0) $
+
explode =  
    zip (map (take 3) $ tail $ tails n)  
+
     unfoldr (\a -> if a==0 then Nothing else Just $ swap $ quotRem a 10)
    [2,3,5,7,11,13,17]
+
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
 
   
 
   
problem_43 = foldr (\x y -> read x + y) 0 $ filter check $ perms "0123456789"
+
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
 
</haskell>
 
</haskell>
  
Line 71: Line 81:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
combine xs = combine' [] xs
+
import Data.Set
    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..]]
+
     head solutions
     where
+
     where  
     f (a,b) = t (abs $ b-a) && t (a+b)
+
     solutions =
    d (a,b) = abs (a-b)
+
        [a-b |
     p n = n*(3*n-1) `div` 2
+
        a <- penta,
    t n = p (fromInteger(round((1+sqrt(24*fromInteger(n)+1))/6))) == n
+
        b <- takeWhile (<a) penta,
 +
        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>
problem_45 = head . dropWhile (<= 40755) $ match tries (match pents hexes)
+
isPent n =  
     where match (x:xs) (y:ys)
+
    (af == 0) && ai `mod` 6 == 5
              | x < y = match xs (y:ys)
+
     where
              | y < x  = match (x:xs) ys
+
    (ai, af) = properFraction $ sqrt $ 1 + 24 * (fromInteger n)
              | otherwise = x : match xs ys
+
   
          tries = [n*(n+1) `div` 2  | n <- [1..]]
+
problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x]
          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
 
  
oddComposites = filter ((>1) . length . primeFactors) [3,5..]
+
millerRabinPrimality on the [[Prime_numbers]] page
  
gbSums = map gbWeight $ weightedPairs gbWeight primes [2*n*n | n <- [1..]]
+
<haskell>
gbWeight (a,b) = a + b
+
import Data.List
 
+
isPrime x
weightedPairs w (x:xs) (y:ys) =
+
     |x==3=True
    (x,y) : mergeWeighted w (map ((,)x) ys) (weightedPairs w xs (y:ys))
+
     |otherwise=millerRabinPrimality x 2
 
+
problem_46 =
mergeWeighted w (x:xs)  (y:ys)
+
    find (\x -> not (isPrime x) && check x) [3,5..]
     | w x <= w y  = x : mergeWeighted w xs (y:ys)
+
    where
     | otherwise   = y : mergeWeighted w (x:xs) ys
+
    check x =  
 
+
        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 (group)
+
import Data.List
 
+
problem_47 = find (all ((==4).snd)) . map (take 4) . tails
factor_lengths :: [(Integer,Int)]
+
                . zip [1..] . map (length . factors) $ [1..]
factor_lengths = [(n, length $ group $ primeFactors n)| n <- [2..]]
+
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..]
  
problem_47 :: Integer
+
primeFactors n = factor n primes
problem_47 = f factor_lengths
+
 
     where
 
     where
         f (a:b:c:d:xs)
+
         factor _ [] = []
            | 4 == snd a && snd a == snd b && snd b == snd c && snd c == snd d = fst a
+
        factor m (p:ps) | p*p > m        = [m]
            | otherwise = f (b:c:d:xs)
+
                        | 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 :: (Integral a) => a -> Bool
+
isPrime x
isprime n = isprime2 2
+
     |x==3=True
     where isprime2 x | x < n    = if n `mod` x == 0 then False else isprime2 (x+1)
+
    |otherwise=millerRabinPrimality x 2
                    | 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)
 
   
 
   
-- 'each' works like this: each (4,1234) => [1,2,3,4]
+
primes = 2 : filter (\x -> isPrime x ) [3..]
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: (prime and isPrime not included)
+
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

Contents

1 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

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 (not . elem (head s)) ys
             return (head s:y)
           ) xs
genSeq ys [] = ys
 
doub xs = nub xs /= xs

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

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

8 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

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

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