Difference between revisions of "Euler problems/51 to 60"
Line 3: | Line 3: | ||
Solution: |
Solution: |
||
+ | |||
+ | millerRabinPrimality on the [[Prime_numbers]] page |
||
+ | |||
<haskell> |
<haskell> |
||
+ | isPrime x |
||
− | import List |
||
+ | |x==3=True |
||
− | primes = 2 : filter ((==1) . length . primeFactors) [3,5..] |
||
+ | |otherwise=millerRabinPrimality x 2 |
||
− | |||
− | 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' |
ch='1' |
||
numChar n= sum [1|x<-show(n),x==ch] |
numChar n= sum [1|x<-show(n),x==ch] |
||
Line 23: | Line 15: | ||
|otherwise=c |
|otherwise=c |
||
nextN repl n= (+0)$read $map repl $show n |
nextN repl n= (+0)$read $map repl $show n |
||
− | same n= [isPrime$nextN (replace a) n |a<-['1'..'9']] |
+ | same n= [if isPrime$nextN (replace a) n then 1 else 0|a<-['1'..'9']] |
problem_51=head [n| |
problem_51=head [n| |
||
n<-[100003,100005..999999], |
n<-[100003,100005..999999], |
||
Line 36: | Line 28: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import List |
||
− | problem_52 = |
||
+ | |||
− | head [n | n <- [1..], |
||
+ | has_same_digits a b = (show a) \\ (show b) == [] |
||
− | digits (2*n) == digits (3*n), |
||
+ | |||
− | digits (3*n) == digits (4*n), |
||
+ | check n = all (has_same_digits n) (map (n*) [2..6]) |
||
− | digits (4*n) == digits (5*n), |
||
+ | |||
− | digits (5*n) == digits (6*n) |
||
+ | problem_52 = head $ filter check [1..] |
||
− | ] |
||
− | where |
||
− | digits = sort . show |
||
</haskell> |
</haskell> |
||
Line 52: | Line 42: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | facs = reverse $ foldl (\y x->(head y) * x : y) [1] [1..100] |
||
− | problem_53 = |
||
+ | comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r)) |
||
− | length [n | n <- [1..100], r <- [1..n], n `choose` r > 10^6] |
||
+ | perms = concat $ map (\x -> [(n,x) | n<-[1..x]]) [1..100] |
||
− | where |
||
+ | problem_53 = length $ filter (>1000000) $ map comb $ perms |
||
− | n `choose` r |
||
− | | r > n || r < 0 = 0 |
||
− | | otherwise = foldl (\z j -> z*(n-j+1) `div` j) n [2..r] |
||
</haskell> |
</haskell> |
||
Line 68: | Line 56: | ||
<haskell> |
<haskell> |
||
− | import Data.List |
+ | import Data.List |
− | import Data.Maybe |
+ | import Data.Maybe |
+ | import Control.Monad |
||
+ | |||
+ | readCard [r,s] = (parseRank r, parseSuit s) |
||
+ | where parseSuit = translate "SHDC" |
||
+ | parseRank = translate "23456789TJQKA" |
||
+ | translate from x = fromJust $ findIndex (==x) from |
||
+ | |||
+ | solveHand hand = (handRank,tiebreak) |
||
+ | where |
||
+ | handRank |
||
+ | | flush && straight = 9 |
||
+ | | hasKinds 4 = 8 |
||
+ | | all hasKinds [2,3] = 7 |
||
+ | | flush = 6 |
||
+ | | straight = 5 |
||
+ | | hasKinds 3 = 4 |
||
+ | | 1 < length (kind 2) = 3 |
||
+ | | hasKinds 2 = 2 |
||
+ | | otherwise = 1 |
||
+ | tiebreak = kind =<< [4,3,2,1] |
||
+ | hasKinds = not . null . kind |
||
+ | kind n = map head $ filter ((n==).length) $ group ranks |
||
+ | ranks = reverse $ sort $ map fst hand |
||
+ | flush = 1 == length (nub (map snd hand)) |
||
+ | straight = length (kind 1) == 5 && 4 == head ranks - last ranks |
||
+ | gameLineToHands = splitAt 5 . map readCard . words |
||
− | data Hand = HighCard | OnePair | TwoPairs | ThreeOfKind | |
||
+ | p1won (a,b) = solveHand a > solveHand b |
||
− | Straight | Flush | FullHouse | FourOfKind | StraightFlush |
||
+ | |||
− | deriving (Show, Read, Enum, Eq, Ord) |
||
+ | problem_54 = do |
||
− | |||
+ | f <- readFile "poker.txt" |
||
− | values :: [(Char, Int)] |
||
+ | let games = map gameLineToHands $ lines f |
||
− | values = zip ['2','3','4','5','6','7','8','9','T','J','Q','K','A'] [1..] |
||
+ | wins = filter p1won games |
||
− | |||
+ | print $ length wins |
||
− | 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 |
||
</haskell> |
</haskell> |
||
Line 153: | Line 99: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | reverseNum = read . reverse . show |
||
− | problem_55 = |
||
+ | |||
− | length $ filter isLychrel [1..9999] |
||
+ | palindrome x = |
||
− | where |
||
+ | sx == reverse sx |
||
− | isLychrel n = all notPalindrome (take 50 (tail (iterate revadd n))) |
||
+ | where |
||
− | notPalindrome s = (show s) /= reverse (show s) |
||
− | + | sx = show x |
|
+ | |||
− | where |
||
+ | lychrel = |
||
− | rev n = read (reverse (show n)) |
||
+ | not . any palindrome . take 50 . tail . iterate next |
||
+ | where |
||
+ | next x = x + reverseNum x |
||
+ | |||
+ | problem_55 = length $ filter lychrel [1..10000] |
||
</haskell> |
</haskell> |
||
Line 168: | Line 119: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | digitalSum 0 = 0 |
||
+ | digitalSum n = |
||
+ | let (d,m) = quotRem n 10 in m + digitalSum d |
||
+ | |||
problem_56 = |
problem_56 = |
||
− | maximum [ |
+ | maximum [digitalSum (a^b) | a <- [99], b <- [90..99]] |
− | where |
||
− | dsum 0 = 0 |
||
− | dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d ) |
||
</haskell> |
</haskell> |
||
Line 180: | Line 132: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | twoex = zip ns ds |
||
+ | where |
||
+ | ns = 3 : zipWith (\x y -> x + 2 * y) ns ds |
||
+ | ds = 2 : zipWith (+) ns ds |
||
+ | |||
+ | len = length . show |
||
+ | |||
problem_57 = |
problem_57 = |
||
− | length $ filter |
+ | length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex |
− | where |
||
− | topHeavy r = numDigits (numerator r) > numDigits (denominator r) |
||
− | numDigits = length . show |
||
− | convergents = iterate next (3%2) |
||
− | next r = 1 + 1/(1+r) |
||
</haskell> |
</haskell> |
||
Line 194: | Line 148: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | isPrime x |
||
− | base :: (Integral a) => [a] |
||
+ | |x==3=True |
||
− | base = base' 2 |
||
+ | |otherwise=all id [millerRabinPrimality x n|n<-[2,3]] |
||
+ | diag = 1:3:5:7:zipWith (+) diag [8,10..] |
||
+ | problem_58 = |
||
+ | result $ dropWhile tooBig $ drop 2 $ scanl primeRatio (0,0) diag |
||
where |
where |
||
+ | primeRatio (n,d) num = (if d `mod` 4 /= 0 && isPrime num then n+1 else n,d+1) |
||
− | base' n = n:n:n:n:(base' $ n + 2) |
||
+ | tooBig (n,d) = n*10 >= d |
||
− | |||
+ | result ((_,d):_) = (d+2) `div` 4 * 2 + 1 |
||
− | 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) |
||
</haskell> |
</haskell> |
||
Line 223: | Line 165: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
− | import Data.Bits |
+ | import Data.Bits |
− | import Data.Char |
+ | import Data.Char |
− | import Data.List |
+ | import Data.List |
+ | |||
− | |||
+ | keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ] |
||
− | common :: [String] |
||
+ | allAlpha a = all (\k -> let a = ord k in (a >= 32 && a <= 122)) a |
||
− | common = ["THE","OF","TO","AND","YOU","THAT","WAS","FOR","WORD"] |
||
+ | howManySpaces x = length (elemIndices ' ' x) |
||
− | |||
+ | compareBy f x y = compare (f x) (f y) |
||
− | keys :: [[Int]] |
||
+ | |||
− | keys = [a:b:c:[]| |
||
+ | problem_59 = do |
||
− | a <- [ord 'a' .. ord 'z'], |
||
+ | s <- readFile "cipher1.txt" |
||
− | b <- [ord 'a' .. ord 'z'], |
||
+ | let |
||
− | c <- [ord 'a' .. ord 'z'] |
||
+ | cipher = (read ("[" ++ s ++ "]") :: [Int]) |
||
− | ] |
||
+ | decrypts = [ (map chr (zipWith xor (cycle key) cipher), map chr key) | key <- keys ] |
||
− | |||
+ | alphaDecrypts = filter (\(x,y) -> allAlpha x) decrypts |
||
− | brute :: [Int] -> [Int] -> ([Int], Int) |
||
+ | message = maximumBy (\(x,y) (x',y') -> compareBy howManySpaces x x') alphaDecrypts |
||
− | brute text key = (key, score) |
||
+ | asciisum = sum (map ord (fst message)) |
||
− | where |
||
+ | putStrLn (show asciisum) |
||
− | 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 |
||
</haskell> |
</haskell> |
||
Line 262: | Line 192: | ||
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. |
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. |
||
<haskell> |
<haskell> |
||
+ | problem_60 = print$sum $head solve |
||
− | import Data.List |
||
+ | isPrime x |
||
− | import Data.Maybe |
||
+ | |x==3=True |
||
− | |||
+ | |otherwise=millerRabinPrimality x 2 |
||
− | primes :: [Integer] |
||
+ | |||
− | primes = 2 : filter (l1 . primeFactors) [3,5..] |
||
+ | solve = do |
||
− | where |
||
+ | a <- primesTo10000 |
||
− | l1 (_:[]) = True |
||
+ | let m = f a $ dropWhile (<= a) primesTo10000 |
||
− | l1 _ = False |
||
+ | b <- m |
||
− | |||
+ | let n = f b $ dropWhile (<= b) m |
||
− | primeFactors :: Integer -> [Integer] |
||
+ | c <- n |
||
− | primeFactors n = factor n primes |
||
+ | let o = f c $ dropWhile (<= c) n |
||
− | where |
||
+ | d <- o |
||
− | factor _ [] = [] |
||
+ | let p = f d $ dropWhile (<= d) o |
||
− | factor m (p:ps) | p*p > m = [m] |
||
+ | e <- p |
||
− | | m `mod` p == 0 = p : factor (m `div` p) (p:ps) |
||
+ | return [a,b,c,d,e] |
||
− | | otherwise = factor m ps |
||
+ | where |
||
− | |||
+ | f x = filter (\y -> all id[isPrime $read $shows x $show y, |
||
− | isPrime :: Integer -> Bool |
||
+ | isPrime $read $shows y $show x]) |
||
− | isPrime 1 = False |
||
+ | primesTo10000 = 2:filter (isPrime) [3,5..9999] |
||
− | 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] |
||
</haskell> |
</haskell> |
Revision as of 03:36, 18 January 2008
Problem 51
Find the smallest prime which, by changing the same part of the number, can form eight different primes.
Solution:
millerRabinPrimality on the Prime_numbers page
isPrime x
|x==3=True
|otherwise=millerRabinPrimality x 2
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= [if isPrime$nextN (replace a) n then 1 else 0|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:
import List
has_same_digits a b = (show a) \\ (show b) == []
check n = all (has_same_digits n) (map (n*) [2..6])
problem_52 = head $ filter check [1..]
Problem 53
How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?
Solution:
facs = reverse $ foldl (\y x->(head y) * x : y) [1] [1..100]
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r))
perms = concat $ map (\x -> [(n,x) | n<-[1..x]]) [1..100]
problem_53 = length $ filter (>1000000) $ map comb $ perms
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
import Data.Maybe
import Control.Monad
readCard [r,s] = (parseRank r, parseSuit s)
where parseSuit = translate "SHDC"
parseRank = translate "23456789TJQKA"
translate from x = fromJust $ findIndex (==x) from
solveHand hand = (handRank,tiebreak)
where
handRank
| flush && straight = 9
| hasKinds 4 = 8
| all hasKinds [2,3] = 7
| flush = 6
| straight = 5
| hasKinds 3 = 4
| 1 < length (kind 2) = 3
| hasKinds 2 = 2
| otherwise = 1
tiebreak = kind =<< [4,3,2,1]
hasKinds = not . null . kind
kind n = map head $ filter ((n==).length) $ group ranks
ranks = reverse $ sort $ map fst hand
flush = 1 == length (nub (map snd hand))
straight = length (kind 1) == 5 && 4 == head ranks - last ranks
gameLineToHands = splitAt 5 . map readCard . words
p1won (a,b) = solveHand a > solveHand b
problem_54 = do
f <- readFile "poker.txt"
let games = map gameLineToHands $ lines f
wins = filter p1won games
print $ length wins
Problem 55
How many Lychrel numbers are there below ten-thousand?
Solution:
reverseNum = read . reverse . show
palindrome x =
sx == reverse sx
where
sx = show x
lychrel =
not . any palindrome . take 50 . tail . iterate next
where
next x = x + reverseNum x
problem_55 = length $ filter lychrel [1..10000]
Problem 56
Considering natural numbers of the form, ab, finding the maximum digital sum.
Solution:
digitalSum 0 = 0
digitalSum n =
let (d,m) = quotRem n 10 in m + digitalSum d
problem_56 =
maximum [digitalSum (a^b) | a <- [99], b <- [90..99]]
Problem 57
Investigate the expansion of the continued fraction for the square root of two.
Solution:
twoex = zip ns ds
where
ns = 3 : zipWith (\x y -> x + 2 * y) ns ds
ds = 2 : zipWith (+) ns ds
len = length . show
problem_57 =
length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex
Problem 58
Investigate the number of primes that lie on the diagonals of the spiral grid.
Solution:
isPrime x
|x==3=True
|otherwise=all id [millerRabinPrimality x n|n<-[2,3]]
diag = 1:3:5:7:zipWith (+) diag [8,10..]
problem_58 =
result $ dropWhile tooBig $ drop 2 $ scanl primeRatio (0,0) diag
where
primeRatio (n,d) num = (if d `mod` 4 /= 0 && isPrime num then n+1 else n,d+1)
tooBig (n,d) = n*10 >= d
result ((_,d):_) = (d+2) `div` 4 * 2 + 1
Problem 59
Using a brute force attack, can you decrypt the cipher using XOR encryption?
Solution:
import Data.Bits
import Data.Char
import Data.List
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ]
allAlpha a = all (\k -> let a = ord k in (a >= 32 && a <= 122)) a
howManySpaces x = length (elemIndices ' ' x)
compareBy f x y = compare (f x) (f y)
problem_59 = do
s <- readFile "cipher1.txt"
let
cipher = (read ("[" ++ s ++ "]") :: [Int])
decrypts = [ (map chr (zipWith xor (cycle key) cipher), map chr key) | key <- keys ]
alphaDecrypts = filter (\(x,y) -> allAlpha x) decrypts
message = maximumBy (\(x,y) (x',y') -> compareBy howManySpaces x x') alphaDecrypts
asciisum = sum (map ord (fst message))
putStrLn (show asciisum)
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.
problem_60 = print$sum $head solve
isPrime x
|x==3=True
|otherwise=millerRabinPrimality x 2
solve = do
a <- primesTo10000
let m = f a $ dropWhile (<= a) primesTo10000
b <- m
let n = f b $ dropWhile (<= b) m
c <- n
let o = f c $ dropWhile (<= c) n
d <- o
let p = f d $ dropWhile (<= d) o
e <- p
return [a,b,c,d,e]
where
f x = filter (\y -> all id[isPrime $read $shows x $show y,
isPrime $read $shows y $show x])
primesTo10000 = 2:filter (isPrime) [3,5..9999]