Personal tools

Euler problems/41 to 50

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
m (Made some changes to problem 49)
Current revision (10:22, 25 August 2012) (edit) (undo)
(→Problem 50)
 
(35 intermediate revisions not shown.)
Line 1: Line 1:
-
[[Category:Programming exercise spoilers]]
 
== [http://projecteuler.net/index.php?section=problems&id=41 Problem 41] ==
== [http://projecteuler.net/index.php?section=problems&id=41 Problem 41] ==
What is the largest n-digit pandigital prime that exists?
What is the largest n-digit pandigital prime that exists?
Line 5: Line 4:
Solution:
Solution:
<haskell>
<haskell>
-
problem_41 = head [p | n <- init (tails "987654321"),
+
-- Assuming isPrime has been implemented
-
p <- perms n, isPrime (read p)]
+
import Data.Char (intToDigit)
-
where perms [] = [[]]
+
problem_41 = maximum [ n' | d <- [3..9], n <- permute ['1'..intToDigit d],
-
perms xs = [x:ps | x <- xs, ps <- perms (delete x xs)]
+
let n' = read n, isPrime n']
-
isPrime n = n > 1 && smallestDivisor n == n
+
where
-
smallestDivisor n = findDivisor n (2:[3,5..])
+
permute "" = [""]
-
findDivisor n (testDivisor:rest)
+
permute str = [(x:xs)| x <- str, xs <- permute (delete x str)]
-
| n `mod` testDivisor == 0 = testDivisor
+
-
| testDivisor*testDivisor >= n = n
+
-
| otherwise = findDivisor n rest
+
</haskell>
</haskell>
Line 22: Line 18:
Solution:
Solution:
<haskell>
<haskell>
-
score :: String -> Int
+
import Data.Char
-
score = sum . map ((subtract 64) . ord . toUpper)
+
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
 +
</haskell>
-
istrig :: Int -> Bool
+
== [http://projecteuler.net/index.php?section=problems&id=43 Problem 43] ==
-
istrig n = istrig' n trigs
+
Find the sum of all pandigital numbers with an unusual sub-string divisibility property.
-
istrig' :: Int -> [Int] -> Bool
+
Solution:
-
istrig' n (t:ts) | n == t = True
+
<haskell>
-
| otherwise = if t < n && head ts > n then False else istrig' n ts
+
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]
-
trigs = map (\n -> n*(n+1) `div` 2) [1..]
+
mults mi ma n = takeWhile (< ma) . dropWhile (<mi) . iterate (+n) $ n
-
--get ws from the Euler site
+
-
ws = ["A","ABILITY" ... "YOURSELF","YOUTH"]
+
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
-
problem_42 = length $ filter id $ map (istrig . score) ws
+
doub xs = nub xs /= xs
</haskell>
</haskell>
-
== [http://projecteuler.net/index.php?section=problems&id=43 Problem 43] ==
+
An arguably cleaner, alternate solution uses nondeterminism + state to create a backtracking monad particularly suited to this problem:
-
Find the sum of all pandigital numbers with an unusual sub-string divisibility property.
+
-
Solution:
 
<haskell>
<haskell>
-
problem_43 = undefined
+
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
 +
</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>
Line 52: Line 149:
Solution:
Solution:
<haskell>
<haskell>
-
problem_44 = undefined
+
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]]
</haskell>
</haskell>
 +
 +
The above solution finds the correct answer but searches the pairs in the wrong order. Lengthier and slower but perhaps more correct solution [https://gist.github.com/2079968 here].
== [http://projecteuler.net/index.php?section=problems&id=45 Problem 45] ==
== [http://projecteuler.net/index.php?section=problems&id=45 Problem 45] ==
Line 60: Line 166:
Solution:
Solution:
<haskell>
<haskell>
-
problem_45 = head . dropWhile (<= 40755) $ match tries (match pents hexes)
+
isPent n = (af == 0) && ai `mod` 6 == 5
-
where match (x:xs) (y:ys)
+
where (ai, af) = properFraction . sqrt $ 1 + 24 * (fromInteger n)
-
| x < y = match xs (y:ys)
+
-
| y < x = match (x:xs) ys
+
problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x]
-
| otherwise = x : match xs ys
+
-
tries = [n*(n+1) `div` 2 | n <- [1..]]
+
-
pents = [n*(3*n-1) `div` 2 | n <- [1..]]
+
-
hexes = [n*(2*n-1) | n <- [1..]]
+
</haskell>
</haskell>
Line 76: Line 178:
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.).
-
+
 
 +
millerRabinPrimality on the [[Prime_numbers]] page
 +
 
<haskell>
<haskell>
-
problem_46 = head $ oddComposites `orderedDiff` gbSums
+
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..]
 +
</haskell>
-
oddComposites = filter ((>1) . length . primeFactors) [3,5..]
+
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.
 +
 
 +
<haskell>
 +
primes :: [Int]
 +
primes = 2 : filter isPrime [3, 5..]
-
gbSums = map gbWeight $ weightedPairs gbWeight primes [2*n*n | n <- [1..]]
+
isPrime :: Int -> Bool
-
gbWeight (a,b) = a + b
+
isPrime n = all (not . divides n) $ takeWhile (\p -> p^2 <= n) primes
 +
where
 +
divides n p = n `mod` p == 0
-
weightedPairs w (x:xs) (y:ys) =
+
compOdds :: [Int]
-
(x,y) : mergeWeighted w (map ((,)x) ys) (weightedPairs w xs (y:ys))
+
compOdds = filter (not . isPrime) [3, 5..]
-
mergeWeighted w (x:xs) (y:ys)
+
verifConj :: Int -> Bool
-
| w x <= w y = x : mergeWeighted w xs (y:ys)
+
verifConj n = any isPrime (takeWhile (>0) $ map (\i -> n - 2*i*i) [1..])
-
| otherwise = y : mergeWeighted w (x:xs) ys
+
-
x `orderedDiff` [] = x
+
problem_46 :: Int
-
[] `orderedDiff` y = []
+
problem_46 = head $ filter (not . verifConj) compOdds
-
(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 105: Line 220:
Solution:
Solution:
<haskell>
<haskell>
-
problem_47 = undefined
+
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
 +
</haskell>
 +
 
 +
 
 +
Alternate Solution:
 +
The previous solution actually didn't give the correct answer for me. The following method did.
 +
 
 +
<haskell>
 +
 
 +
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
 +
 
</haskell>
</haskell>
Line 113: Line 274:
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>
 +
problem_48 = (`mod` limit) $ sum [powMod limit n n | n <- [1..1000]]
 +
where limit=10^10
 +
</haskell>
 +
 +
Another one-liner for this problem, with no use of other functions is the following:
<haskell>
<haskell>
-
problem_48 = sum [n^n | n <- [1..1000]] `mod` 10^10
+
problem_48 = reverse $ take 10
 +
$ reverse $ show $ sum $ map (\x -> x^x) [1..1000]
</haskell>
</haskell>
Line 121: Line 292:
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 library functions where possible...makes it slightly faster on my system. [[User:Jim Burton|Jim Burton]] 10:02, 9 July 2007 (UTC)
 
<haskell>
<haskell>
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
+
-
+
-
 
+
-
-- 'each' works like this: each (1234,4) => [1,2,3,4]
+
-
each :: (Int, Int) -> [Int]
+
-
each = unfoldr (\(y,o) -> let x = 10 ^ (o-1)
+
-
(d,m) = y `divMod` x in
+
-
if o == 0 then Nothing else Just (d,(m,o-1)))
+
-
 
+
-
ispermut :: Int -> Int -> Bool
+
-
ispermut x y = sort (each (x,4)) == sort (each (y,4))
+
-
isin :: (Eq a) => a -> [[a]] -> Bool
+
primes4 = filter isPrime [1000..9999]
-
isin = any . elem
+
-
problem_49_1 :: [Int] -> [[Int]] -> [[Int]]
+
problem_49 = [ (a,b,c) | a <- primes4,
-
problem_49_1 [] res = res
+
b <- dropWhile (<= a) primes4,
-
problem_49_1 (pr:prims) res = problem_49_1 prims res'
+
sort (show a) == sort (show b),
-
where res' = if pr `isin` res then res else res ++ [pr:(filter (ispermut pr) (pr:prims))]
+
let c = 2 * b - a,
-
 
+
c `elem` primes4,
-
problem_49 :: [[Int]]
+
sort (show a) == sort (show c) ]
-
problem_49 = problem_49_1 [n | n <- [1000..9999], isprime n] []
+
</haskell>
</haskell>
Line 158: Line 314:
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:
+
Solution:
 +
(prime and isPrime not included)
 +
 
<haskell>
<haskell>
-
problem_50 = undefined
+
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
</haskell>
</haskell>
-
[[Category:Tutorials]]
+
* This code is wrong: if you switch ''init'' and ''tail'', it produces wrong result, so it is by sheer luck that it produces the right answer at all. As written, it will produce the longest chain of primes ending at 546-th prime, summing up to a prime - using 546 as it is the longest prefix of primes summing up to less than a million. That's not what the problem asks for.
-
[[Category:Code]]
+
 
 +
:What's to guarantee us there's no longer chain ending at 545-th prime? 544-th? For instance, for 1,100,000 the longest sequence ends at 568-th instead of 571-st prime which is what the above code would use.
 +
 
 +
:Moreover, cutting the search short at just first 546 primes is wrong too. What if the longest chain was really short, like 10 or 20 primes? Then we'd have to go much higher into the primes. We have no way of knowing that length in advance.
 +
 
 +
* Here's my solution, it's not the fastest but is correct, feel free to criticise (isPrime and primes not included):
 +
<haskell>
 +
import Euler.Helpers
 +
import qualified Data.List as L
 +
 
 +
prime n = takeWhileSum n primes
 +
takeWhileSum n = takeWhileArr (\x -> sum x <= n)
 +
takeWhileArr f xs = takeWhileF f [] xs
 +
where
 +
takeWhileF f rs [] = reverse rs
 +
takeWhileF f rs (x:xs)
 +
| f (x:rs) = takeWhileF f (x:rs) xs
 +
| otherwise = reverse rs
 +
 
 +
primeSums n = map (map (\x -> (isPrime x,x) ) . takeWhile (<n) . scanl1 (+)) (L.tails (prime n))
 +
main = print . maximum $ map index (primeSums 100000)
 +
where index x = if null $ ind x
 +
then (0,0)
 +
else (last $ ind x, snd (x !! (last $ ind x)))
 +
ind = L.findIndices (fst)
 +
</haskell>

Current revision

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

The above solution finds the correct answer but searches the pairs in the wrong order. Lengthier and slower but perhaps more correct solution here.

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

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
  • This code is wrong: if you switch init and tail, it produces wrong result, so it is by sheer luck that it produces the right answer at all. As written, it will produce the longest chain of primes ending at 546-th prime, summing up to a prime - using 546 as it is the longest prefix of primes summing up to less than a million. That's not what the problem asks for.
What's to guarantee us there's no longer chain ending at 545-th prime? 544-th? For instance, for 1,100,000 the longest sequence ends at 568-th instead of 571-st prime which is what the above code would use.
Moreover, cutting the search short at just first 546 primes is wrong too. What if the longest chain was really short, like 10 or 20 primes? Then we'd have to go much higher into the primes. We have no way of knowing that length in advance.
  • Here's my solution, it's not the fastest but is correct, feel free to criticise (isPrime and primes not included): 
import Euler.Helpers
import qualified Data.List as L
 
prime n = takeWhileSum n primes
takeWhileSum n = takeWhileArr (\x -> sum x <= n)
takeWhileArr f xs = takeWhileF f [] xs
    where
        takeWhileF f rs [] = reverse rs
        takeWhileF f rs (x:xs)
            | f (x:rs) = takeWhileF f (x:rs) xs
            | otherwise = reverse rs
 
primeSums n = map (map (\x -> (isPrime x,x) ) . takeWhile (<n) . scanl1 (+)) (L.tails (prime n))
main = print . maximum $ map index (primeSums 100000)
    where index x = if null $ ind x 
                    then (0,0) 
                    else (last $ ind x, snd (x !! (last $ ind x)))
          ind = L.findIndices (fst)
Retrieved from "http://www.haskell.org/haskellwiki/Euler_problems/41_to_50"