Difference between revisions of "Euler problems/41 to 50"

From HaskellWiki
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 = n
+
head.filter isprime.filter fun $ [7654321,7654320..]
| otherwise = findDivisor n rest
+
where
  +
fun =(=="1234567").sort.show
 
</haskell>
 
</haskell>
   
Line 23: Line 23:
 
<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 41:
 
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 78:
 
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 93:
 
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 107:
   
 
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 127:
 
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 144:
 
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 157:
   
 
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 184:
 
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

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

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

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

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

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

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

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

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