Personal tools

Euler problems/51 to 60

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
([http://projecteuler.net/index.php?section=problems&id=53 Problem 53]: a solution)
m
 
(25 intermediate revisions by 12 users not shown)
Line 3: Line 3:
  
 
Solution:
 
Solution:
 +
 +
millerRabinPrimality on the [[Prime_numbers]] page
 +
 
<haskell>
 
<haskell>
problem_51 = undefined
+
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>
 
</haskell>
  
Line 12: Line 28:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_52 = undefined
+
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>
 
</haskell>
  
Line 20: Line 42:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_53 = length [n | n <- [1..100], r <- [1..n], n `choose` r > 10^6]
+
facs = scanl (*) 1 [1..100]
    where n `choose` r
+
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r))
          | r > n || r < 0 = 0
+
perms = [(n,x) | x<-[1..100], n<-[1..x]]
          | otherwise      = foldl (\z j -> z*(n-j+1) `div` j) n [2..r]
+
problem_53 = length $ filter (>1000000) $ map comb $ perms
 
</haskell>
 
</haskell>
  
 
== [http://projecteuler.net/index.php?section=problems&id=54 Problem 54] ==
 
== [http://projecteuler.net/index.php?section=problems&id=54 Problem 54] ==
How many hands did player one win in the game of poker?
+
How many hands did player one win in the [http://www.pokerroom.com poker games]?
  
 
Solution:
 
Solution:
 +
 +
probably not the most straight forward way to do it.
 +
 
<haskell>
 
<haskell>
problem_54 = undefined
+
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
 
</haskell>
 
</haskell>
  
Line 39: Line 99:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_55 = length $ filter isLychrel [1..9999]
+
reverseNum = read . reverse . show
     where isLychrel n = all notPalindrome (take 50 (tail (iterate revadd n)))
+
          notPalindrome s = (show s) /= reverse (show s)
+
palindrome x =
          revadd n = n + rev n
+
    sx == reverse sx
              where rev n = read (reverse (show n))
+
     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>
 
</haskell>
  
Line 51: Line 119:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_56 = maximum [dsum (a^b) | a <- [1..99], b <-[1..99]]
+
digitalSum 0 = 0
    where dsum 0 = 0
+
digitalSum n =
          dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d )
+
    let (d,m) = quotRem n 10 in m + digitalSum d
 +
 +
problem_56 =  
 +
    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 61: Line 143:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_57 = undefined
+
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>
 +
 
 +
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 69: Line 171:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_58 = undefined
+
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 + 1
 
</haskell>
 
</haskell>
  
Line 77: Line 188:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_59 = undefined
+
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
 
</haskell>
 
</haskell>
  
Line 84: Line 212:
  
 
Solution:
 
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>
 
<haskell>
problem_60 = undefined
+
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]
 
</haskell>
 
</haskell>
 
[[Category:Tutorials]]
 
[[Category:Code]]
 

Latest revision as of 00:17, 17 February 2010

Contents

[edit] 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
    ]

[edit] 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..]

[edit] 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

[edit] 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

[edit] 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]

[edit] 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]]

[edit] 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

[edit] 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 + 1

[edit] 9 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

[edit] 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]