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']]
problem_51=head [n|
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
g1 = head g
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
a<-readFile "poker.txt"
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]