Euler problems/51 to 60

Problem 51

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

Solution:

problem_51 = undefined

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

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]

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

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

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 )

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)

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)

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

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]