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:

import List
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
 
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 1 = 0
isPrime n = case (primeFactors n) of
                (_:_:_)   -> 0
                _         -> 1
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= [isPrime$nextN (replace a) n |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:

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
main=do
    a<-readFile "poker.txt"
    print $problem_54 a

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]