# Euler problems/51 to 60

### From HaskellWiki

Line 36: | Line 36: | ||

Solution: |
Solution: |
||

+ | |||

+ | probably not the most straight forward way to do it. |
||

+ | |||

<haskell> |
<haskell> |
||

− | problem_54 = undefined |
+ | 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 |
||

</haskell> |
</haskell> |
||

## Revision as of 15:11, 9 August 2007

## Contents |

## 1 Problem 51

Find the smallest prime which, by changing the same part of the number, can form eight different primes.

Solution:

problem_51 = undefined

## 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:

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

## 3 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]

## 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 (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

## 5 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))

## 6 Problem 56

Considering natural numbers of the form, a^{b}, 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 )

## 7 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)

## 8 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)

## 9 Problem 59

Using a brute force attack, can you decrypt the cipher using XOR encryption?

Solution:

problem_59 = undefined

## 10 Problem 60

Find a set of five primes for which any two primes concatenate to produce another prime.

Solution:

problem_60 = undefined