Personal tools

Euler problems/51 to 60

From HaskellWiki

< Euler problems
Revision as of 12:35, 16 August 2007 by Oboudry (Talk | contribs)

Jump to: navigation, search

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, ab, 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:

import Data.Bits (xor)
import Data.Char (toUpper, ord, chr)
import Data.List (sortBy)
 
common :: [String]
common = ["THE","OF","TO","AND","YOU","THAT","WAS","FOR","WORD"]
 
keys :: [[Int]]
keys = [a:b:c:[]| a <- [ord 'a' .. ord 'z'], b <- [ord 'a' .. ord 'z'], c <- [ord 'a' .. ord 'z']]
 
brute :: [Int] -> [Int] -> ([Int], Int)
brute text key = (key, score)
    where
        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

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.

import Data.List
import Data.Maybe
 
primes :: [Integer]
primes = 2 : filter (l1 . primeFactors) [3,5..]
    where
        l1 (_:[]) = True
        l1      _ = False
 
primeFactors :: Integer -> [Integer]
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 :: Integer -> Bool
isPrime 1 = False
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]