Euler problems/51 to 60
From HaskellWiki
< Euler problems(Difference between revisions)
(rv: vandalism) |
m |
||
| (7 intermediate revisions not shown.) | |||
| Line 42: | Line 42: | ||
Solution: | Solution: | ||
<haskell> | <haskell> | ||
| - | facs = | + | facs = scanl (*) 1 [1..100] |
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r)) | comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r)) | ||
| - | perms = | + | perms = [(n,x) | x<-[1..100], n<-[1..x]] |
problem_53 = length $ filter (>1000000) $ map comb $ perms | problem_53 = length $ filter (>1000000) $ map comb $ perms | ||
</haskell> | </haskell> | ||
| Line 63: | Line 63: | ||
where parseSuit = translate "SHDC" | where parseSuit = translate "SHDC" | ||
parseRank = translate "23456789TJQKA" | parseRank = translate "23456789TJQKA" | ||
| - | translate from x = fromJust $ | + | translate from x = fromJust $ elemIndex x from |
solveHand hand = (handRank,tiebreak) | solveHand hand = (handRank,tiebreak) | ||
| Line 80: | Line 80: | ||
hasKinds = not . null . kind | hasKinds = not . null . kind | ||
kind n = map head $ filter ((n==).length) $ group ranks | kind n = map head $ filter ((n==).length) $ group ranks | ||
| - | ranks = | + | ranks = sortBy (flip compare) $ map fst hand |
flush = 1 == length (nub (map snd hand)) | flush = 1 == length (nub (map snd hand)) | ||
straight = length (kind 1) == 5 && 4 == head ranks - last ranks | straight = length (kind 1) == 5 && 4 == head ranks - last ranks | ||
| Line 125: | Line 125: | ||
problem_56 = | problem_56 = | ||
maximum [digitalSum (a^b) | a <- [99], b <- [90..99]] | maximum [digitalSum (a^b) | a <- [99], b <- [90..99]] | ||
| + | </haskell> | ||
| + | |||
| + | Alternate solution: | ||
| + | <haskell> | ||
| + | import Data.Char (digitToInt) | ||
| + | |||
| + | digiSum :: Integer -> Int | ||
| + | digiSum = sum . map digitToInt . show | ||
| + | |||
| + | problem_56 :: Int | ||
| + | problem_56 = maximum $ map digiSum [a^b | a <- [1..100], b <- [1..100]] | ||
</haskell> | </haskell> | ||
| Line 141: | Line 152: | ||
problem_57 = | problem_57 = | ||
length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex | length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex | ||
| + | </haskell> | ||
| + | |||
| + | The following solution is based on the observation that the fractions needed appear regularly in the repeating pattern _______$____$ where underscores are ignored and dollars are interesting fractions. | ||
| + | |||
| + | <haskell> | ||
| + | calc :: Int -> Int | ||
| + | calc n = nd13 * 2 + ((n-nd13*13) `div` 8) | ||
| + | where | ||
| + | nd13 = n `div` 13 | ||
| + | |||
| + | problem_57 :: Int | ||
| + | problem_57 = calc 1000 | ||
</haskell> | </haskell> | ||
| Line 150: | Line 173: | ||
isPrime x | isPrime x | ||
|x==3=True | |x==3=True | ||
| - | |otherwise= | + | |otherwise=and [millerRabinPrimality x n|n<-[2,3]] |
diag = 1:3:5:7:zipWith (+) diag [8,10..] | diag = 1:3:5:7:zipWith (+) diag [8,10..] | ||
problem_58 = | problem_58 = | ||
| Line 168: | Line 191: | ||
import Data.Char | import Data.Char | ||
import Data.List | import Data.List | ||
| + | import Data.Ord (comparing) | ||
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ] | keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ] | ||
| - | allAlpha | + | allAlpha = all (\k -> let a = ord k in (a >= 32 && a <= 122)) |
| - | howManySpaces | + | howManySpaces = length . filter (==' ') |
| - | + | ||
problem_59 = do | problem_59 = do | ||
| Line 178: | Line 201: | ||
let | let | ||
cipher = (read ("[" ++ s ++ "]") :: [Int]) | cipher = (read ("[" ++ s ++ "]") :: [Int]) | ||
| - | decrypts = [ | + | decrypts = [ map chr (zipWith xor (cycle key) cipher) | key <- keys ] |
| - | alphaDecrypts = filter | + | alphaDecrypts = filter allAlpha decrypts |
| - | message = maximumBy ( | + | message = maximumBy (comparing howManySpaces) alphaDecrypts |
| - | asciisum = sum (map ord | + | asciisum = sum (map ord message) |
| - | + | print asciisum | |
</haskell> | </haskell> | ||
| Line 193: | Line 216: | ||
<haskell> | <haskell> | ||
problem_60 = print$sum $head solve | problem_60 = print$sum $head solve | ||
| - | isPrime x | + | isPrime x = x==3 || millerRabinPrimality x 2 |
| - | + | ||
| - | + | ||
solve = do | solve = do | ||
| Line 209: | Line 230: | ||
return [a,b,c,d,e] | return [a,b,c,d,e] | ||
where | where | ||
| - | f x = filter (\y -> | + | f x = filter (\y -> and [isPrime $read $shows x $show y, |
isPrime $read $shows y $show x]) | isPrime $read $shows y $show x]) | ||
| - | primesTo10000 = 2:filter | + | primesTo10000 = 2:filter isPrime [3,5..9999] |
</haskell> | </haskell> | ||
Current revision
Contents |
1 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
]2 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..]
3 Problem 53
How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?
Solution:
facs = scanl (*) 1 [1..100] comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r)) perms = [(n,x) | x<-[1..100], n<-[1..x]] problem_53 = length $ filter (>1000000) $ map comb $ perms
4 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 $ elemIndex 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 = sortBy (flip compare) $ 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
5 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]
6 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]]
Alternate solution:
import Data.Char (digitToInt) digiSum :: Integer -> Int digiSum = sum . map digitToInt . show problem_56 :: Int problem_56 = maximum $ map digiSum [a^b | a <- [1..100], b <- [1..100]]
7 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
The following solution is based on the observation that the fractions needed appear regularly in the repeating pattern _______$____$ where underscores are ignored and dollars are interesting fractions.
calc :: Int -> Int calc n = nd13 * 2 + ((n-nd13*13) `div` 8) where nd13 = n `div` 13 problem_57 :: Int problem_57 = calc 1000
8 Problem 58
Investigate the number of primes that lie on the diagonals of the spiral grid.
Solution:
isPrime x
|x==3=True
|otherwise=and [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 + 19 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 import Data.Ord (comparing) keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ] allAlpha = all (\k -> let a = ord k in (a >= 32 && a <= 122)) howManySpaces = length . filter (==' ') problem_59 = do s <- readFile "cipher1.txt" let cipher = (read ("[" ++ s ++ "]") :: [Int]) decrypts = [ map chr (zipWith xor (cycle key) cipher) | key <- keys ] alphaDecrypts = filter allAlpha decrypts message = maximumBy (comparing howManySpaces) alphaDecrypts asciisum = sum (map ord message) print asciisum
10 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 || 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 -> and [isPrime $read $shows x $show y, isPrime $read $shows y $show x]) primesTo10000 = 2:filter isPrime [3,5..9999]
