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

## 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)]
```

## 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 (notElem (head s)) ys
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 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
```

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
| n < 10    = "00" ++ show n
| n < 100   = "0"  ++ show n
| otherwise = show n
```

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

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

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

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

## 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) ]
```

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