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

From HaskellWiki
Jump to: navigation, search
(rv: vandalism)
Line 1: Line 1:
−
Do them on your own!
  
  +
== [http://projecteuler.net/index.php?section=problems&id=51 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
  +
  +
<haskell>
  +
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
  +
]
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=52 Problem 52] ==
  +
Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits in some order.
  +
  +
Solution:
  +
<haskell>
  +
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..]
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=53 Problem 53] ==
  +
How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?
  +
  +
Solution:
  +
<haskell>
  +
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
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=54 Problem 54] ==
  +
How many hands did player one win in the [http://www.pokerroom.com poker games]?
  +
  +
Solution:
  +
  +
probably not the most straight forward way to do it.
  +
  +
<haskell>
  +
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
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=55 Problem 55] ==
  +
How many Lychrel numbers are there below ten-thousand?
  +
  +
Solution:
  +
<haskell>
  +
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]
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=56 Problem 56] ==
  +
Considering natural numbers of the form, a<sup>b</sup>, finding the maximum digital sum.
  +
  +
Solution:
  +
<haskell>
  +
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]]
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=57 Problem 57] ==
  +
Investigate the expansion of the continued fraction for the square root of two.
  +
  +
Solution:
  +
<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 =
  +
length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=58 Problem 58] ==
  +
Investigate the number of primes that lie on the diagonals of the spiral grid.
  +
  +
Solution:
  +
<haskell>
  +
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
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=59 Problem 59] ==
  +
Using a brute force attack, can you decrypt the cipher using XOR encryption?
  +
  +
Solution:
  +
<haskell>
  +
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)
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=problems&id=60 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.
  +
<haskell>
  +
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]
  +
</haskell>

Revision as of 04:58, 30 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]
Retrieved from "https://wiki.haskell.org/index.php?title=Euler_problems/51_to_60&oldid=18795"