Euler problems/41 to 50
From HaskellWiki
Martinhrvn (Talk  contribs) (→Problem 50) 

(24 intermediate revisions by 12 users not shown)  
Line 1:  Line 1:  
−  == [http://projecteuler.net/index.php?section=view&id=41 Problem 41] == 
+  == [http://projecteuler.net/index.php?section=problems&id=41 Problem 41] == 
What is the largest ndigit pandigital prime that exists? 
What is the largest ndigit pandigital prime that exists? 

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 
+  problem_41 = maximum [ n'  d < [3..9], n < permute ['1'..intToDigit d], 
−  perms [] = [[]] 
+  let n' = read n, isPrime n'] 
−  perms xs = [x:ps  x < xs, ps < perms (delete x xs)] 
+  where 
−  isPrime n = n > 1 && smallestDivisor n == n 
+  permute "" = [""] 
−  smallestDivisor n = findDivisor n (2:[3,5..]) 
+  permute str = [(x:xs) x < str, xs < permute (delete x str)] 
−  findDivisor n (testDivisor:rest) 

−   n `mod` testDivisor == 0 = testDivisor 

−   testDivisor*testDivisor >= n = n 

−   otherwise = findDivisor n rest 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=42 Problem 42] == 
+  == [http://projecteuler.net/index.php?section=problems&id=42 Problem 42] == 
How many triangle words can you make using the list of common English words? 
How many triangle words can you make using the list of common English words? 

Line 19:  Line 19:  
<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 

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

+  
+  == [http://projecteuler.net/index.php?section=problems&id=43 Problem 43] == 

+  Find the sum of all pandigital numbers with an unusual substring divisibility property. 

+  
+  Solution: 

+  <haskell> 

+  import Data.List 

+  l2n :: (Integral a) => [a] > a 

+  l2n = foldl' (\a b > 10*a+b) 0 

−  istrig n = istrig' n trigs 
+  swap (a,b) = (b,a) 
−  istrig' n (t:ts) 
+  explode :: (Integral a) => a > [a] 
−   n == t = True 
+  explode = 
−   otherwise = if t < n && head ts > n 
+  unfoldr (\a > if a==0 then Nothing else Just $ swap $ quotRem a 10) 
−  then False 
+  problem_43 = sum . map l2n . map (\s > head ([0..9] \\ s):s) 
−  else istrig' n ts 
+  . filter (elem 0) . genSeq [] $ [17,13,11,7,5,3,2] 
+  
+  mults mi ma n = takeWhile (< ma) . dropWhile (<mi) . iterate (+n) $ n 

−  trigs = map (\n > n*(n+1) `div` 2) [1..] 
+  sequ xs ys = tail xs == init ys 
−  problem_42 ws= length $ filter id $ map (istrig . score) ws 
+  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 

−  main=do 
+  doub xs = nub xs /= xs 
−  f<readFile "words.txt" 
+  </haskell> 
−  let words=tail$("":)$read $"["++f++"]" 

−  print $problem_42 words 

+  An arguably cleaner, alternate solution uses nondeterminism + state to create a backtracking monad particularly suited to this problem: 

+  
+  <haskell> 

+  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> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=43 Problem 43] == 
+  An almost instant answer can be generated by only creating permutations which fulfil the requirement of particular digits being multiples of certain numbers. 
−  Find the sum of all pandigital numbers with an unusual substring divisibility property. 

−  Solution: 

<haskell> 
<haskell> 

−  import Data.List (inits, tails) 
+  import Data.List ((\\), nub) 
−  +  
−  perms [] = [[]] 
+  main = print q43 
−  perms (x:xs) = 
+  
−  [ p ++ [x] ++ s  
+  q43 = sum [ read n  (d7d8d9, remDigits) < permMults digits 17, 
−  xs' < perms xs , 
+  (d4d5d6, remDigits') < permMults remDigits 7, 
−  (p, s) < zip (inits xs') (tails xs') 
+  d4d5d6 !! 1 == '0'  d4d5d6 !! 1 == '5', 
−  ] 
+  (d1d2d3, remDigit) < permMults remDigits' 2, 
−  +  let n = remDigit ++ d1d2d3 ++ d4d5d6 ++ d7d8d9, 

−  check n = 
+  hasProperty (tail n) primes] 
−  all (\x > (read $ fst x) `mod` snd x == 0) $ 
+  where 
−  zip (map (take 3) $ tail $ tails n) 
+  digits = "0123456789" 
−  [2,3,5,7,11,13,17] 
+  primes = [2,3,5,7,11,13,17] 
−  +  hasProperty _ [] = True 

−  problem_43 = foldr (\x y > read x + y) 0 $ filter check $ perms "0123456789" 
+  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> 

−  == [http://projecteuler.net/index.php?section=view&id=44 Problem 44] == 
+  == [http://projecteuler.net/index.php?section=problems&id=44 Problem 44] == 
Find the smallest pair of pentagonal numbers whose sum and difference is pentagonal. 
Find the smallest pair of pentagonal numbers whose sum and difference is pentagonal. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  combine xs = combine' [] xs 
+  import Data.Set 
−  where 
+  problem_44 = head solutions 
−  combine' acc (x:xs) = map (\n > (n, x)) acc ++ combine' (x:acc) xs 
+  where solutions = [ab  a < penta, 
+  b < takeWhile (<a) penta, 

+  isPenta (ab), 

+  isPenta (b+a) ] 

+  isPenta = (`member` fromList penta) 

+  penta = [(n * (3*n1)) `div` 2  n < [1..5000]] 

+  </haskell> 

−  problem_44 = 
+  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]. 
−  d $ head $ filter f $ combine [p n n < [1..]] 

−  where 

−  f (a,b) = t (abs $ ba) && t (a+b) 

−  d (a,b) = abs (ab) 

−  p n = n*(3*n1) `div` 2 

−  t n = p (fromInteger(round((1+sqrt(24*fromInteger(n)+1))/6))) == n 

−  </haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=45 Problem 45] == 
+  == [http://projecteuler.net/index.php?section=problems&id=45 Problem 45] == 
After 40755, what is the next triangle number that is also pentagonal and hexagonal? 
After 40755, what is the next triangle number that is also pentagonal and hexagonal? 

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*n1) `div` 2  n < [1..]] 

−  hexes = [n*(2*n1)  n < [1..]] 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=46 Problem 46] == 
+  == [http://projecteuler.net/index.php?section=problems&id=46 Problem 46] == 
What is the smallest odd composite that cannot be written as the sum of a prime and twice a square? 
What is the smallest odd composite that cannot be written as the sum of a prime and twice a square? 

Line 87:  Line 131:  
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: 
−  gbSums = map gbWeight $ weightedPairs gbWeight primes [2*n*n  n < [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. 
−  gbWeight (a,b) = a + b 

−  weightedPairs w (x:xs) (y:ys) = 
+  <haskell> 
−  (x,y) : mergeWeighted w (map ((,)x) ys) (weightedPairs w xs (y:ys)) 
+  primes :: [Int] 
+  primes = 2 : filter isPrime [3, 5..] 

−  mergeWeighted w (x:xs) (y:ys) 
+  isPrime :: Int > Bool 
−   w x <= w y = x : mergeWeighted w xs (y:ys) 
+  isPrime n = all (not . divides n) $ takeWhile (\p > p^2 <= n) primes 
−   otherwise = y : mergeWeighted w (x:xs) ys 
+  where 
+  divides n p = n `mod` p == 0 

−  x `orderedDiff` [] = x 
+  compOdds :: [Int] 
−  [] `orderedDiff` y = [] 
+  compOdds = filter (not . isPrime) [3, 5..] 
−  (x:xs) `orderedDiff` (y:ys) 
+  
−   x < y = x : xs `orderedDiff` (y:ys) 
+  verifConj :: Int > Bool 
−   x > y = (x:xs) `orderedDiff` ys 
+  verifConj n = any isPrime (takeWhile (>0) $ map (\i > n  2*i*i) [1..]) 
−   otherwise = xs `orderedDiff` ys 
+  
+  problem_46 :: Int 

+  problem_46 = head $ filter (not . verifConj) compOdds 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=47 Problem 47] == 
+  == [http://projecteuler.net/index.php?section=problems&id=47 Problem 47] == 
Find the first four consecutive integers to have four distinct primes factors. 
Find the first four consecutive integers to have four distinct primes factors. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  import Data.List (group) 
+  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..] 

−  factor_lengths :: [(Integer,Int)] 
+  primeFactors n = factor n primes 
−  factor_lengths = [(n, length $ group $ primeFactors n) n < [2..]] 
+  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 

−  problem_47 :: Integer 

−  problem_47 = f factor_lengths 

−  where 

−  f (a:b:c:d:xs) 

−   4 == snd a && snd a == snd b && snd b == snd c && snd c == snd d = fst a 

−   otherwise = f (b:c:d:xs) 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=48 Problem 48] == 
+  == [http://projecteuler.net/index.php?section=problems&id=48 Problem 48] == 
Find the last ten digits of 1<sup>1</sup> + 2<sup>2</sup> + ... + 1000<sup>1000</sup>. 
Find the last ten digits of 1<sup>1</sup> + 2<sup>2</sup> + ... + 1000<sup>1000</sup>. 

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 
+  problem_48 = (`mod` limit) $ sum [powMod limit n n  n < [1..1000]] 
−  mulMod a b c= (b * c) `rem` a 
+  where limit=10^10 
−  squareMod :: Integral a => a > a > a 
+  </haskell> 
−  squareMod a b = (b * b) `rem` a 
+  
−  pow' :: (Num a, Integral b) => (a > a > a) > (a > a) > a > b > a 
+  Another oneliner for this problem, with no use of other functions is the following: 
−  pow' _ _ _ 0 = 1 
+  <haskell> 
−  pow' mul sq x' n' = f x' n' 1 
+  problem_48 = reverse $ take 10 
−  where 
+  $ reverse $ show $ sum $ map (\x > x^x) [1..1000] 
−  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]] 

−  where 

−  limit=10^10 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=49 Problem 49] == 
+  == [http://projecteuler.net/index.php?section=problems&id=49 Problem 49] == 
Find arithmetic sequences, made of prime terms, whose four digits are permutations of each other. 
Find arithmetic sequences, made of prime terms, whose four digits are permutations of each other. 

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 BurtonJim Burton]] 10:02, 9 July 2007 (UTC) 

<haskell> 
<haskell> 

import Data.List 
import Data.List 

−  isprime :: (Integral a) => a > Bool 

−  isprime n = isprime2 2 

−  where isprime2 x  x < n = if n `mod` x == 0 then False else isprime2 (x+1) 

−   otherwise = True 

−  
−  
−   'each' works like this: each (4,1234) => [1,2,3,4] 

−  each :: (Int, Int) > [Int] 

−  each = unfoldr (\(o,y) > let x = 10 ^ (o1) 

−  (d,m) = y `divMod` x in 

−  if o == 0 then Nothing else Just (d,(o1,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)=[xyy<xs]++(unAdd xs) 

−  takeEqv []=[] 

−  takeEqv (x:xs)=[xy<xs,xy==0]++(takeEqv xs) 

−  div2un []=[] 

−  div2un (x:xs)=[div (xy) 2y<xs]++(div2un xs) 

−  eqvList x y =[aa<x,b<y,a==b] 

−  problem_49 =[y 
+  isPrime x 
−  x<p49a, 
+   x==3 = True 
−  let y=sort$nub x, 
+   otherwise = millerRabinPrimality x 2 
−  length(y)>=4, 

−  let z=unAdd y, 

−  length(z)/=length(nub z), 

−  (eqvList (div2un y) (takeEqv z))/=[] 

−  ] 

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

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=50 Problem 50] == 
+  == [http://projecteuler.net/index.php?section=problems&id=50 Problem 50] == 
Which prime, below onemillion, can be written as the sum of the most consecutive primes? 
Which prime, below onemillion, 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 

Line 208:  Line 221:  
problem_50 = findPrimeSum $ take 546 primes 
problem_50 = findPrimeSum $ take 546 primes 

+  </haskell> 

+  
+  * 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 546th 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 545th prime? 544th? For instance, for 1,100,000 the longest sequence ends at 568th instead of 571st 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> 
</haskell> 
Latest revision as of 10:22, 25 August 2012
Contents 
[edit] 1 Problem 41
What is the largest ndigit 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)]
[edit] 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
[edit] 3 Problem 43
Find the sum of all pandigital numbers with an unusual substring 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
[edit] 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 = [ab  a < penta, b < takeWhile (<a) penta, isPenta (ab), isPenta (b+a) ] isPenta = (`member` fromList penta) penta = [(n * (3*n1)) `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.
[edit] 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]
[edit] 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
[edit] 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
[edit] 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 oneliner 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]
[edit] 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) ]
[edit] 10 Problem 50
Which prime, below onemillion, 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 546th 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 545th prime? 544th? For instance, for 1,100,000 the longest sequence ends at 568th instead of 571st 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)