Add solutions for problem 46-50.

Euler.hs

@@ -11,6 +11,7 @@ module Euler
   , primesTo
   , isPrimeArray
   , primes
+  , primeFactors
   , zipArraysWith
   , RangeIx(..)
   , divisors
@@ -22,6 +23,7 @@ module Euler
   , fromDigits
   , fromDigitsBase
   , isPalindrome
+  , (\\\)
   , module Control.Applicative
   , module Control.Arrow
   , module Control.Monad
@@ -73,7 +75,20 @@ isPrimeArray n = runSTUArray $ do
    return isPrime
 
 primes :: [Integer]
-primes = let go (!p:xs) = p : go [ x | x <- xs, x `mod` p /= 0 ] in go [2..]
+--primes = let go (!p:xs) = p : go [ x | x <- xs, x `mod` p /= 0 ] in go [2..]
+primes = go 1000000
+   where
+      go n = primesTo n ++ dropWhile (<= n) (go (2*n))
+
+primeFactors :: Integer -> [Integer]
+primeFactors n = go n primes
+   where
+      go 0 _ = [0]
+      go 1 _ = []
+      go n (p:ps)
+         | n < 0 = (-1) : go (negate n) (p:ps)
+         | (q, 0) <- n `divMod` p = p : go q (p:ps)
+         | otherwise = go n ps
 
 class Ix a => RangeIx a where
    intersectBounds :: (a, a) -> (a, a) -> (a, a)
@@ -141,3 +156,11 @@ fromDigitsBase n = foldl' (\a b -> n * a + fromIntegral b) 0
 
 isPalindrome :: Eq a => [a] -> Bool
 isPalindrome xs = xs == reverse xs
+
+-- Like (\\), but assumes both lists are sorted.
+(\\\) :: Ord a => [a] -> [a] -> [a]
+(a:as) \\\ (b:bs) = case compare a b of
+   LT -> a : (as \\\ (b:bs))
+   EQ ->      as \\\ (b:bs)
+   GT ->      (a:as) \\\ bs
+infix 5 \\\

Problem046.hs

@@ -0,0 +1,11 @@
+-- What is the smallest odd composite that cannot be written as the sum of a
+-- prime and twice a square?
+
+import Euler
+
+composites = [1..] \\\ primes
+isTwiceSquare n = 2 * ((floor $ sqrt $ (/ 2) $ fromIntegral n) ^ 2) == n
+
+main = print $ head $ do
+   n <- tail $ filter odd composites
+   n <$ (guard $ not $ any isTwiceSquare $ map (n-) $ takeWhile (< n) primes)

Problem047.hs

@@ -0,0 +1,10 @@
+-- Find the first four consecutive integers to have four distinct prime
+-- factors. What is the first of these numbers?
+
+import Euler
+
+distinct = map head . group
+nFactors = map (id &&& length . distinct . primeFactors) [1..]
+
+main = print $ map fst $ head $
+   filter (all (==4) . map snd) $ map (take 4) $ tails nFactors

Problem048.hs

@@ -0,0 +1,2 @@
+-- Find the last ten digits of the series, 1^1 + 2^2 + 3^3 + ... + 1000^1000.
+main = print $ (`mod` 10000000000) $ sum $ map (\n -> n^n) [1..1000]

Problem049.hs

@@ -0,0 +1,23 @@
+-- The arithmetic sequence, 1487, 4817, 8147, in which each of the terms
+-- increases by 3330, is unusual in two ways: (i) each of the three terms are
+-- prime, and, (ii) each of the 4-digit numbers are permutations of one
+-- another.
+--
+-- There are no arithmetic sequences made up of three 1-, 2-, or 3-digit
+-- primes, exhibiting this property, but there is one other 4-digit increasing
+-- sequence.
+--
+-- What 12-digit number do you form by concatenating the three terms in this
+-- sequence?
+
+import Euler
+
+main = print $ head $ do
+   p  <- takeWhile (<= 9999) $ dropWhile (<= 1487) $ primes
+   p' <- takeWhile (<= 9999) $ dropWhile (<= p)    $ primes
+   let p'' = 2 * p' - p
+   guard $ p'' <= 9999
+   guard $ p'' `elem` takeWhile (<= p'') primes
+   guard $ sort (toDigits p)  == sort (toDigits p')
+   guard $ sort (toDigits p') == sort (toDigits p'')
+   return $ fromDigits $ toDigits p ++ toDigits p' ++ toDigits p''

Problem050.hs

@@ -0,0 +1,19 @@
+-- Which prime, below one-million, can be written as the sum of the most
+-- consecutive primes?
+
+import Euler
+
+intersectOn' :: (a -> b -> Ordering) -> [a] -> [b] -> [b]
+intersectOn' _ []     _      = []
+intersectOn' _ _      []     = []
+intersectOn' f (x:xs) (y:ys) = case f x y of
+   LT ->     intersectOn' f xs (y:ys)
+   EQ -> y : intersectOn' f xs     ys
+   GT ->     intersectOn' f (x:xs) ys
+
+primeSums = concat $
+   map (intersectOn' (\p (_,q) -> compare p q) primes) $
+   map (zip [1..] . takeWhile (< 1000000) . tail . scanl' (+) 0) $
+   tails $ takeWhile (< 50000) $ primes
+
+main = print $ snd $ maximumBy (compare `on` fst) $ primeSums