# Difference between revisions of "Euler problems/51 to 60"

## Problem 51

Find the smallest prime which, by changing the same part of the number, can form eight different primes.

Solution:

```import List
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 : factor (m `div` p) (p:ps)
| otherwise      = factor m ps

isPrime 1 = 0
isPrime n = case (primeFactors n) of
(_:_:_)   -> 0
_         -> 1
ch='1'
numChar n= sum [1|x<-show(n),x==ch]
replace d c|c==ch=d
|otherwise=c
nextN repl n= (+0)\$read \$map repl \$show n
same n= [isPrime\$nextN (replace a) n |a<-['1'..'9']]
n<-[100003,100005..999999],
numChar n==3,
(sum \$same n)==8
]
```

## Problem 52

Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits in some order.

Solution:

```problem_52 =
head [n | n <- [1..],
digits (2*n) == digits (3*n),
digits (3*n) == digits (4*n),
digits (4*n) == digits (5*n),
digits (5*n) == digits (6*n)
]
where
digits = sort . show
```

## Problem 53

How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?

Solution:

```problem_53 =
length [n | n <- [1..100], r <- [1..n], n `choose` r > 10^6]
where
n `choose` r
| r > n || r < 0 = 0
| otherwise      = foldl (\z j -> z*(n-j+1) `div` j) n [2..r]
```

## Problem 54

How many hands did player one win in the poker games?

Solution:

probably not the most straight forward way to do it.

```import Data.List (sort, sortBy, tails, lookup, groupBy)
import Data.Maybe (fromJust)

data Hand = HighCard | OnePair | TwoPairs | ThreeOfKind |
Straight | Flush | FullHouse | FourOfKind | StraightFlush
deriving (Show, Read, Enum, Eq, Ord)

values :: [(Char, Int)]
values = zip ['2','3','4','5','6','7','8','9','T','J','Q','K','A'] [1..]

value :: String -> Int
value (c:cs) = fromJust \$ lookup c values

suites :: [[Char]]
suites = map sort \$ take 9 \$ map (take 5) \$ tails cards

cards :: [Char]
cards = ['2','3','4','5','6','7','8','9','T','J','Q','K','A']

flush :: [String] -> Bool
flush = a . extractSuit
where
a (x:y:xs) = x == y && a (y:xs)
a _ = True
extractSuit = map s
where
s (_:y:ys) = y

straight :: [String] -> Bool
straight = a . extractValues
where
a xs = any (==(sort xs)) suites
extractValues = map v
where
v (x:xs) = x

groupByKind :: [String] -> [[String]]
groupByKind = sortBy l . groupBy g . sortBy s
where
s (a) (b) = compare (value b) (value a)
g (a:_) (b:_) = a == b
l a b = compare (length b) (length a)

guessHand :: [String] -> Hand
guessHand cards
| straight cards && flush cards = StraightFlush
| length g1 == 4 = FourOfKind
| length g1 == 3 && length g2 == 2 = FullHouse
| flush cards = Flush
| straight cards = Straight
| length g1 == 3 = ThreeOfKind
| length g1 == 2 && length g2 == 2 = TwoPairs
| length g1 == 2 = OnePair
| otherwise = HighCard
where
g = groupByKind cards
g2 = head \$ tail g

playerOneScore :: ([String], [String]) -> Int
playerOneScore (p1, p2)
| a == b    = compare p1 p2
| a > b     = 1
| otherwise = 0
where
a = guessHand p1
b = guessHand p2
compare p1 p2 =
if ((map value \$ concat \$ groupByKind p1) >
(map value \$ concat \$ groupByKind p2))
then 1
else 0

problem_54 :: String -> Int
problem_54 = sum . map (\x -> playerOneScore \$ splitAt 5 \$ words x) . lines
main=do
print \$problem_54 a
```

## Problem 55

How many Lychrel numbers are there below ten-thousand?

Solution:

```problem_55 =
length \$ filter isLychrel [1..9999]
where
isLychrel n = all notPalindrome (take 50 (tail (iterate revadd n)))
notPalindrome s = (show s) /= reverse (show s)
revadd n = n + rev n
where
rev n = read (reverse (show n))
```

## Problem 56

Considering natural numbers of the form, ab, finding the maximum digital sum.

Solution:

```problem_56 =
maximum [dsum (a^b) | a <- [1..99], b <-[1..99]]
where
dsum 0 = 0
dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d )
```

## Problem 57

Investigate the expansion of the continued fraction for the square root of two.

Solution:

```problem_57 =
length \$ filter topHeavy \$ take 1000 convergents
where
topHeavy r = numDigits (numerator r) > numDigits (denominator r)
numDigits = length . show
convergents = iterate next (3%2)
next r = 1 + 1/(1+r)
```

## Problem 58

Investigate the number of primes that lie on the diagonals of the spiral grid.

Solution:

```base :: (Integral a) => [a]
base = base' 2
where
base' n = n:n:n:n:(base' \$ n + 2)

pascal = scanl (+) 1 base

ratios :: [Integer] -> [Double]
ratios (x:xs) = 1.0 : ratios' 0 1 xs
where
ratios' n d (w:x:y:z:xs) =
((fromInteger num)/(fromInteger den)) : (ratios' num den xs)
where
num = (p w + p x + p y + p z + n)
den = (d + 4)
p n = case isPrime n of
True -> 1
False -> 0

problem_58 =
fst \$ head \$ dropWhile (\(_,a) -> a > 0.1) \$
zip [1,3..] (ratios pascal)
```

## Problem 59

Using a brute force attack, can you decrypt the cipher using XOR encryption?

Solution:

```import Data.Bits (xor)
import Data.Char (toUpper, ord, chr)
import Data.List (sortBy)

common :: [String]
common = ["THE","OF","TO","AND","YOU","THAT","WAS","FOR","WORD"]

keys :: [[Int]]
keys = [a:b:c:[]|
a <- [ord 'a' .. ord 'z'],
b <- [ord 'a' .. ord 'z'],
c <- [ord 'a' .. ord 'z']
]

brute :: [Int] -> [Int] -> ([Int], Int)
brute text key = (key, score)
where
score = sum \$ map (\x -> if (any (==x) common) then 1 else 0)
(words \$ map toUpper \$ decrypt key text)

decrypt :: [Int] -> [Int] -> String
decrypt key text = [chr (t `xor` k)|(t,k) <- zip text (cycle key)]

problem_59 :: String -> Int
problem_59 text = sum \$ map ord \$ decrypt bestKey b
where
b = map read \$ words \$ map (\x -> if x == ',' then ' ' else x) text
bestKey = fst \$ head \$
sortBy (\(_,s1) (_,s2) -> compare s2 s1)  \$
map (brute b) \$ keys
```

## Problem 60

Find a set of five primes for which any two primes concatenate to produce another prime.

Solution:

Breadth first search that works on infinite lists. Breaks the 60 secs rule. This program finds the solution in 185 sec on my Dell D620 Laptop.

```import Data.List
import Data.Maybe

primes :: [Integer]
primes = 2 : filter (l1 . primeFactors) [3,5..]
where
l1 (_:[]) = True
l1      _ = False

primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
where
factor _ [] = []
factor m (p:ps) | p*p > m        = [m]
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
| otherwise      = factor m ps

isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
(_:[]) -> True
_      -> False

combine :: (Show a, Ord a) => [[a]] -> [[a]]
combine ls = combine' [] ls
where
combine' seen (x:xs) = mapMaybe m seen ++ combine' (seen ++ [x]) xs
where
c y = group \$ sort \$ y ++ x
d y = map head \$ filter l1 \$ c y
h y = map head \$ c y
t (x:y:[]) = test x y
t _ = False
l1 (x:[]) = True
l1 _ = False
m y
| t \$ d y = Just \$ h y
| otherwise = Nothing

test a b
| isPrime c1 && isPrime c2 = True
| otherwise                = False
where
c1 = read \$ (show a) ++ (show b)
c2 = read \$ (show b) ++ (show a)

problem_60 :: Integer
problem_60 =
sum \$ head \$ nub \$ combine \$
nub \$ combine \$ nub \$ combine \$
combine [[x]| x <- primes]
```