Euler problems/51 to 60

problem_51 = undefined

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 = 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]

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

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)

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

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]